1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Exp_Disp; use Exp_Disp;
34 with Exp_Tss; use Exp_Tss;
35 with Exp_Util; use Exp_Util;
37 with Lib.Xref; use Lib.Xref;
38 with Namet; use Namet;
39 with Nlists; use Nlists;
40 with Nmake; use Nmake;
42 with Restrict; use Restrict;
43 with Rident; use Rident;
44 with Rtsfind; use Rtsfind;
46 with Sem_Aux; use Sem_Aux;
47 with Sem_Case; use Sem_Case;
48 with Sem_Ch3; use Sem_Ch3;
49 with Sem_Ch6; use Sem_Ch6;
50 with Sem_Ch8; use Sem_Ch8;
51 with Sem_Ch9; use Sem_Ch9;
52 with Sem_Dim; use Sem_Dim;
53 with Sem_Disp; use Sem_Disp;
54 with Sem_Eval; use Sem_Eval;
55 with Sem_Prag; use Sem_Prag;
56 with Sem_Res; use Sem_Res;
57 with Sem_Type; use Sem_Type;
58 with Sem_Util; use Sem_Util;
59 with Sem_Warn; use Sem_Warn;
60 with Sinput; use Sinput;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Sinfo; use Sinfo;
64 with Stringt; use Stringt;
65 with Targparm; use Targparm;
66 with Ttypes; use Ttypes;
67 with Tbuild; use Tbuild;
68 with Urealp; use Urealp;
69 with Warnsw; use Warnsw;
71 with GNAT.Heap_Sort_G;
73 package body Sem_Ch13 is
75 SSU : constant Pos := System_Storage_Unit;
76 -- Convenient short hand for commonly used constant
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint);
83 -- This routine is called after setting one of the sizes of type entity
84 -- Typ to Size. The purpose is to deal with the situation of a derived
85 -- type whose inherited alignment is no longer appropriate for the new
86 -- size value. In this case, we reset the Alignment to unknown.
88 procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
89 -- If Typ has predicates (indicated by Has_Predicates being set for Typ,
90 -- then either there are pragma Predicate entries on the rep chain for the
91 -- type (note that Predicate aspects are converted to pragma Predicate), or
92 -- there are inherited aspects from a parent type, or ancestor subtypes.
93 -- This procedure builds the spec and body for the Predicate function that
94 -- tests these predicates. N is the freeze node for the type. The spec of
95 -- the function is inserted before the freeze node, and the body of the
96 -- function is inserted after the freeze node. If the predicate expression
97 -- has at least one Raise_Expression, then this procedure also builds the
98 -- M version of the predicate function for use in membership tests.
100 procedure Build_Static_Predicate
104 -- Given a predicated type Typ, where Typ is a discrete static subtype,
105 -- whose predicate expression is Expr, tests if Expr is a static predicate,
106 -- and if so, builds the predicate range list. Nam is the name of the one
107 -- argument to the predicate function. Occurrences of the type name in the
108 -- predicate expression have been replaced by identifier references to this
109 -- name, which is unique, so any identifier with Chars matching Nam must be
110 -- a reference to the type. If the predicate is non-static, this procedure
111 -- returns doing nothing. If the predicate is static, then the predicate
112 -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as
113 -- a canonicalized membership operation.
115 procedure Freeze_Entity_Checks (N : Node_Id);
116 -- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
117 -- to generate appropriate semantic checks that are delayed until this
118 -- point (they had to be delayed this long for cases of delayed aspects,
119 -- e.g. analysis of statically predicated subtypes in choices, for which
120 -- we have to be sure the subtypes in question are frozen before checking.
122 function Get_Alignment_Value (Expr : Node_Id) return Uint;
123 -- Given the expression for an alignment value, returns the corresponding
124 -- Uint value. If the value is inappropriate, then error messages are
125 -- posted as required, and a value of No_Uint is returned.
127 function Is_Operational_Item (N : Node_Id) return Boolean;
128 -- A specification for a stream attribute is allowed before the full type
129 -- is declared, as explained in AI-00137 and the corrigendum. Attributes
130 -- that do not specify a representation characteristic are operational
133 procedure New_Stream_Subprogram
137 Nam : TSS_Name_Type);
138 -- Create a subprogram renaming of a given stream attribute to the
139 -- designated subprogram and then in the tagged case, provide this as a
140 -- primitive operation, or in the non-tagged case make an appropriate TSS
141 -- entry. This is more properly an expansion activity than just semantics,
142 -- but the presence of user-defined stream functions for limited types is a
143 -- legality check, which is why this takes place here rather than in
144 -- exp_ch13, where it was previously. Nam indicates the name of the TSS
145 -- function to be generated.
147 -- To avoid elaboration anomalies with freeze nodes, for untagged types
148 -- we generate both a subprogram declaration and a subprogram renaming
149 -- declaration, so that the attribute specification is handled as a
150 -- renaming_as_body. For tagged types, the specification is one of the
154 with procedure Replace_Type_Reference (N : Node_Id);
155 procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id);
156 -- This is used to scan an expression for a predicate or invariant aspect
157 -- replacing occurrences of the name TName (the name of the subtype to
158 -- which the aspect applies) with appropriate references to the parameter
159 -- of the predicate function or invariant procedure. The procedure passed
160 -- as a generic parameter does the actual replacement of node N, which is
161 -- either a simple direct reference to TName, or a selected component that
162 -- represents an appropriately qualified occurrence of TName.
168 Biased : Boolean := True);
169 -- If Biased is True, sets Has_Biased_Representation flag for E, and
170 -- outputs a warning message at node N if Warn_On_Biased_Representation is
171 -- is True. This warning inserts the string Msg to describe the construct
174 ----------------------------------------------
175 -- Table for Validate_Unchecked_Conversions --
176 ----------------------------------------------
178 -- The following table collects unchecked conversions for validation.
179 -- Entries are made by Validate_Unchecked_Conversion and then the call
180 -- to Validate_Unchecked_Conversions does the actual error checking and
181 -- posting of warnings. The reason for this delayed processing is to take
182 -- advantage of back-annotations of size and alignment values performed by
185 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
186 -- that by the time Validate_Unchecked_Conversions is called, Sprint will
187 -- already have modified all Sloc values if the -gnatD option is set.
189 type UC_Entry is record
190 Eloc : Source_Ptr; -- node used for posting warnings
191 Source : Entity_Id; -- source type for unchecked conversion
192 Target : Entity_Id; -- target type for unchecked conversion
195 package Unchecked_Conversions is new Table.Table (
196 Table_Component_Type => UC_Entry,
197 Table_Index_Type => Int,
198 Table_Low_Bound => 1,
200 Table_Increment => 200,
201 Table_Name => "Unchecked_Conversions");
203 ----------------------------------------
204 -- Table for Validate_Address_Clauses --
205 ----------------------------------------
207 -- If an address clause has the form
209 -- for X'Address use Expr
211 -- where Expr is of the form Y'Address or recursively is a reference to a
212 -- constant of either of these forms, and X and Y are entities of objects,
213 -- then if Y has a smaller alignment than X, that merits a warning about
214 -- possible bad alignment. The following table collects address clauses of
215 -- this kind. We put these in a table so that they can be checked after the
216 -- back end has completed annotation of the alignments of objects, since we
217 -- can catch more cases that way.
219 type Address_Clause_Check_Record is record
221 -- The address clause
224 -- The entity of the object overlaying Y
227 -- The entity of the object being overlaid
230 -- Whether the address is offset within Y
233 package Address_Clause_Checks is new Table.Table (
234 Table_Component_Type => Address_Clause_Check_Record,
235 Table_Index_Type => Int,
236 Table_Low_Bound => 1,
238 Table_Increment => 200,
239 Table_Name => "Address_Clause_Checks");
241 -----------------------------------------
242 -- Adjust_Record_For_Reverse_Bit_Order --
243 -----------------------------------------
245 procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
250 -- Processing depends on version of Ada
252 -- For Ada 95, we just renumber bits within a storage unit. We do the
253 -- same for Ada 83 mode, since we recognize the Bit_Order attribute in
254 -- Ada 83, and are free to add this extension.
256 if Ada_Version < Ada_2005 then
257 Comp := First_Component_Or_Discriminant (R);
258 while Present (Comp) loop
259 CC := Component_Clause (Comp);
261 -- If component clause is present, then deal with the non-default
262 -- bit order case for Ada 95 mode.
264 -- We only do this processing for the base type, and in fact that
265 -- is important, since otherwise if there are record subtypes, we
266 -- could reverse the bits once for each subtype, which is wrong.
268 if Present (CC) and then Ekind (R) = E_Record_Type then
270 CFB : constant Uint := Component_Bit_Offset (Comp);
271 CSZ : constant Uint := Esize (Comp);
272 CLC : constant Node_Id := Component_Clause (Comp);
273 Pos : constant Node_Id := Position (CLC);
274 FB : constant Node_Id := First_Bit (CLC);
276 Storage_Unit_Offset : constant Uint :=
277 CFB / System_Storage_Unit;
279 Start_Bit : constant Uint :=
280 CFB mod System_Storage_Unit;
283 -- Cases where field goes over storage unit boundary
285 if Start_Bit + CSZ > System_Storage_Unit then
287 -- Allow multi-byte field but generate warning
289 if Start_Bit mod System_Storage_Unit = 0
290 and then CSZ mod System_Storage_Unit = 0
293 ("multi-byte field specified with non-standard"
294 & " Bit_Order??", CLC);
296 if Bytes_Big_Endian then
298 ("bytes are not reversed "
299 & "(component is big-endian)??", CLC);
302 ("bytes are not reversed "
303 & "(component is little-endian)??", CLC);
306 -- Do not allow non-contiguous field
310 ("attempt to specify non-contiguous field "
311 & "not permitted", CLC);
313 ("\caused by non-standard Bit_Order "
316 ("\consider possibility of using "
317 & "Ada 2005 mode here", CLC);
320 -- Case where field fits in one storage unit
323 -- Give warning if suspicious component clause
325 if Intval (FB) >= System_Storage_Unit
326 and then Warn_On_Reverse_Bit_Order
329 ("Bit_Order clause does not affect " &
330 "byte ordering?V?", Pos);
332 Intval (Pos) + Intval (FB) /
335 ("position normalized to ^ before bit " &
336 "order interpreted?V?", Pos);
339 -- Here is where we fix up the Component_Bit_Offset value
340 -- to account for the reverse bit order. Some examples of
341 -- what needs to be done are:
343 -- First_Bit .. Last_Bit Component_Bit_Offset
355 -- The rule is that the first bit is is obtained by
356 -- subtracting the old ending bit from storage_unit - 1.
358 Set_Component_Bit_Offset
360 (Storage_Unit_Offset * System_Storage_Unit) +
361 (System_Storage_Unit - 1) -
362 (Start_Bit + CSZ - 1));
364 Set_Normalized_First_Bit
366 Component_Bit_Offset (Comp) mod
367 System_Storage_Unit);
372 Next_Component_Or_Discriminant (Comp);
375 -- For Ada 2005, we do machine scalar processing, as fully described In
376 -- AI-133. This involves gathering all components which start at the
377 -- same byte offset and processing them together. Same approach is still
378 -- valid in later versions including Ada 2012.
382 Max_Machine_Scalar_Size : constant Uint :=
384 (Standard_Long_Long_Integer_Size);
385 -- We use this as the maximum machine scalar size
388 SSU : constant Uint := UI_From_Int (System_Storage_Unit);
391 -- This first loop through components does two things. First it
392 -- deals with the case of components with component clauses whose
393 -- length is greater than the maximum machine scalar size (either
394 -- accepting them or rejecting as needed). Second, it counts the
395 -- number of components with component clauses whose length does
396 -- not exceed this maximum for later processing.
399 Comp := First_Component_Or_Discriminant (R);
400 while Present (Comp) loop
401 CC := Component_Clause (Comp);
405 Fbit : constant Uint := Static_Integer (First_Bit (CC));
406 Lbit : constant Uint := Static_Integer (Last_Bit (CC));
409 -- Case of component with last bit >= max machine scalar
411 if Lbit >= Max_Machine_Scalar_Size then
413 -- This is allowed only if first bit is zero, and
414 -- last bit + 1 is a multiple of storage unit size.
416 if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then
418 -- This is the case to give a warning if enabled
420 if Warn_On_Reverse_Bit_Order then
422 ("multi-byte field specified with "
423 & " non-standard Bit_Order?V?", CC);
425 if Bytes_Big_Endian then
427 ("\bytes are not reversed "
428 & "(component is big-endian)?V?", CC);
431 ("\bytes are not reversed "
432 & "(component is little-endian)?V?", CC);
436 -- Give error message for RM 13.5.1(10) violation
440 ("machine scalar rules not followed for&",
441 First_Bit (CC), Comp);
443 Error_Msg_Uint_1 := Lbit;
444 Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
446 ("\last bit (^) exceeds maximum machine "
450 if (Lbit + 1) mod SSU /= 0 then
451 Error_Msg_Uint_1 := SSU;
453 ("\and is not a multiple of Storage_Unit (^) "
458 Error_Msg_Uint_1 := Fbit;
460 ("\and first bit (^) is non-zero "
466 -- OK case of machine scalar related component clause,
467 -- For now, just count them.
470 Num_CC := Num_CC + 1;
475 Next_Component_Or_Discriminant (Comp);
478 -- We need to sort the component clauses on the basis of the
479 -- Position values in the clause, so we can group clauses with
480 -- the same Position. together to determine the relevant machine
484 Comps : array (0 .. Num_CC) of Entity_Id;
485 -- Array to collect component and discriminant entities. The
486 -- data starts at index 1, the 0'th entry is for the sort
489 function CP_Lt (Op1, Op2 : Natural) return Boolean;
490 -- Compare routine for Sort
492 procedure CP_Move (From : Natural; To : Natural);
493 -- Move routine for Sort
495 package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
499 -- Start and stop positions in the component list of the set of
500 -- components with the same starting position (that constitute
501 -- components in a single machine scalar).
504 -- Maximum last bit value of any component in this set
507 -- Corresponding machine scalar size
513 function CP_Lt (Op1, Op2 : Natural) return Boolean is
515 return Position (Component_Clause (Comps (Op1))) <
516 Position (Component_Clause (Comps (Op2)));
523 procedure CP_Move (From : Natural; To : Natural) is
525 Comps (To) := Comps (From);
528 -- Start of processing for Sort_CC
531 -- Collect the machine scalar relevant component clauses
534 Comp := First_Component_Or_Discriminant (R);
535 while Present (Comp) loop
537 CC : constant Node_Id := Component_Clause (Comp);
540 -- Collect only component clauses whose last bit is less
541 -- than machine scalar size. Any component clause whose
542 -- last bit exceeds this value does not take part in
543 -- machine scalar layout considerations. The test for
544 -- Error_Posted makes sure we exclude component clauses
545 -- for which we already posted an error.
548 and then not Error_Posted (Last_Bit (CC))
549 and then Static_Integer (Last_Bit (CC)) <
550 Max_Machine_Scalar_Size
552 Num_CC := Num_CC + 1;
553 Comps (Num_CC) := Comp;
557 Next_Component_Or_Discriminant (Comp);
560 -- Sort by ascending position number
562 Sorting.Sort (Num_CC);
564 -- We now have all the components whose size does not exceed
565 -- the max machine scalar value, sorted by starting position.
566 -- In this loop we gather groups of clauses starting at the
567 -- same position, to process them in accordance with AI-133.
570 while Stop < Num_CC loop
575 (Last_Bit (Component_Clause (Comps (Start))));
576 while Stop < Num_CC loop
578 (Position (Component_Clause (Comps (Stop + 1)))) =
580 (Position (Component_Clause (Comps (Stop))))
588 (Component_Clause (Comps (Stop)))));
594 -- Now we have a group of component clauses from Start to
595 -- Stop whose positions are identical, and MaxL is the
596 -- maximum last bit value of any of these components.
598 -- We need to determine the corresponding machine scalar
599 -- size. This loop assumes that machine scalar sizes are
600 -- even, and that each possible machine scalar has twice
601 -- as many bits as the next smaller one.
603 MSS := Max_Machine_Scalar_Size;
605 and then (MSS / 2) >= SSU
606 and then (MSS / 2) > MaxL
611 -- Here is where we fix up the Component_Bit_Offset value
612 -- to account for the reverse bit order. Some examples of
613 -- what needs to be done for the case of a machine scalar
616 -- First_Bit .. Last_Bit Component_Bit_Offset
628 -- The rule is that the first bit is obtained by subtracting
629 -- the old ending bit from machine scalar size - 1.
631 for C in Start .. Stop loop
633 Comp : constant Entity_Id := Comps (C);
634 CC : constant Node_Id := Component_Clause (Comp);
636 LB : constant Uint := Static_Integer (Last_Bit (CC));
637 NFB : constant Uint := MSS - Uint_1 - LB;
638 NLB : constant Uint := NFB + Esize (Comp) - 1;
639 Pos : constant Uint := Static_Integer (Position (CC));
642 if Warn_On_Reverse_Bit_Order then
643 Error_Msg_Uint_1 := MSS;
645 ("info: reverse bit order in machine " &
646 "scalar of length^?V?", First_Bit (CC));
647 Error_Msg_Uint_1 := NFB;
648 Error_Msg_Uint_2 := NLB;
650 if Bytes_Big_Endian then
652 ("\info: big-endian range for "
653 & "component & is ^ .. ^?V?",
654 First_Bit (CC), Comp);
657 ("\info: little-endian range "
658 & "for component & is ^ .. ^?V?",
659 First_Bit (CC), Comp);
663 Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
664 Set_Normalized_First_Bit (Comp, NFB mod SSU);
671 end Adjust_Record_For_Reverse_Bit_Order;
673 -------------------------------------
674 -- Alignment_Check_For_Size_Change --
675 -------------------------------------
677 procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint) is
679 -- If the alignment is known, and not set by a rep clause, and is
680 -- inconsistent with the size being set, then reset it to unknown,
681 -- we assume in this case that the size overrides the inherited
682 -- alignment, and that the alignment must be recomputed.
684 if Known_Alignment (Typ)
685 and then not Has_Alignment_Clause (Typ)
686 and then Size mod (Alignment (Typ) * SSU) /= 0
688 Init_Alignment (Typ);
690 end Alignment_Check_For_Size_Change;
692 -------------------------------------
693 -- Analyze_Aspects_At_Freeze_Point --
694 -------------------------------------
696 procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is
701 procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
702 -- This routine analyzes an Aspect_Default_[Component_]Value denoted by
703 -- the aspect specification node ASN.
705 procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id);
706 -- As discussed in the spec of Aspects (see Aspect_Delay declaration),
707 -- a derived type can inherit aspects from its parent which have been
708 -- specified at the time of the derivation using an aspect, as in:
710 -- type A is range 1 .. 10
711 -- with Size => Not_Defined_Yet;
715 -- Not_Defined_Yet : constant := 64;
717 -- In this example, the Size of A is considered to be specified prior
718 -- to the derivation, and thus inherited, even though the value is not
719 -- known at the time of derivation. To deal with this, we use two entity
720 -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A
721 -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in
722 -- the derived type (B here). If this flag is set when the derived type
723 -- is frozen, then this procedure is called to ensure proper inheritance
724 -- of all delayed aspects from the parent type. The derived type is E,
725 -- the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first
726 -- aspect specification node in the Rep_Item chain for the parent type.
728 procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
729 -- Given an aspect specification node ASN whose expression is an
730 -- optional Boolean, this routines creates the corresponding pragma
731 -- at the freezing point.
733 ----------------------------------
734 -- Analyze_Aspect_Default_Value --
735 ----------------------------------
737 procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
738 Ent : constant Entity_Id := Entity (ASN);
739 Expr : constant Node_Id := Expression (ASN);
740 Id : constant Node_Id := Identifier (ASN);
743 Error_Msg_Name_1 := Chars (Id);
745 if not Is_Type (Ent) then
746 Error_Msg_N ("aspect% can only apply to a type", Id);
749 elsif not Is_First_Subtype (Ent) then
750 Error_Msg_N ("aspect% cannot apply to subtype", Id);
753 elsif A_Id = Aspect_Default_Value
754 and then not Is_Scalar_Type (Ent)
756 Error_Msg_N ("aspect% can only be applied to scalar type", Id);
759 elsif A_Id = Aspect_Default_Component_Value then
760 if not Is_Array_Type (Ent) then
761 Error_Msg_N ("aspect% can only be applied to array type", Id);
764 elsif not Is_Scalar_Type (Component_Type (Ent)) then
765 Error_Msg_N ("aspect% requires scalar components", Id);
770 Set_Has_Default_Aspect (Base_Type (Ent));
772 if Is_Scalar_Type (Ent) then
773 Set_Default_Aspect_Value (Ent, Expr);
775 -- Place default value of base type as well, because that is
776 -- the semantics of the aspect. It is convenient to link the
777 -- aspect to both the (possibly anonymous) base type and to
778 -- the given first subtype.
780 Set_Default_Aspect_Value (Base_Type (Ent), Expr);
783 Set_Default_Aspect_Component_Value (Ent, Expr);
785 end Analyze_Aspect_Default_Value;
787 ---------------------------------
788 -- Inherit_Delayed_Rep_Aspects --
789 ---------------------------------
791 procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is
792 P : constant Entity_Id := Entity (ASN);
793 -- Entithy for parent type
796 -- Item from Rep_Item chain
801 -- Loop through delayed aspects for the parent type
804 while Present (N) loop
805 if Nkind (N) = N_Aspect_Specification then
806 exit when Entity (N) /= P;
808 if Is_Delayed_Aspect (N) then
809 A := Get_Aspect_Id (Chars (Identifier (N)));
811 -- Process delayed rep aspect. For Boolean attributes it is
812 -- not possible to cancel an attribute once set (the attempt
813 -- to use an aspect with xxx => False is an error) for a
814 -- derived type. So for those cases, we do not have to check
815 -- if a clause has been given for the derived type, since it
816 -- is harmless to set it again if it is already set.
822 when Aspect_Alignment =>
823 if not Has_Alignment_Clause (E) then
824 Set_Alignment (E, Alignment (P));
829 when Aspect_Atomic =>
830 if Is_Atomic (P) then
836 when Aspect_Atomic_Components =>
837 if Has_Atomic_Components (P) then
838 Set_Has_Atomic_Components (Base_Type (E));
843 when Aspect_Bit_Order =>
844 if Is_Record_Type (E)
845 and then No (Get_Attribute_Definition_Clause
846 (E, Attribute_Bit_Order))
847 and then Reverse_Bit_Order (P)
849 Set_Reverse_Bit_Order (Base_Type (E));
854 when Aspect_Component_Size =>
856 and then not Has_Component_Size_Clause (E)
859 (Base_Type (E), Component_Size (P));
864 when Aspect_Machine_Radix =>
865 if Is_Decimal_Fixed_Point_Type (E)
866 and then not Has_Machine_Radix_Clause (E)
868 Set_Machine_Radix_10 (E, Machine_Radix_10 (P));
871 -- Object_Size (also Size which also sets Object_Size)
873 when Aspect_Object_Size | Aspect_Size =>
874 if not Has_Size_Clause (E)
876 No (Get_Attribute_Definition_Clause
877 (E, Attribute_Object_Size))
879 Set_Esize (E, Esize (P));
885 if not Is_Packed (E) then
886 Set_Is_Packed (Base_Type (E));
888 if Is_Bit_Packed_Array (P) then
889 Set_Is_Bit_Packed_Array (Base_Type (E));
890 Set_Packed_Array_Type (E, Packed_Array_Type (P));
894 -- Scalar_Storage_Order
896 when Aspect_Scalar_Storage_Order =>
897 if (Is_Record_Type (E) or else Is_Array_Type (E))
898 and then No (Get_Attribute_Definition_Clause
899 (E, Attribute_Scalar_Storage_Order))
900 and then Reverse_Storage_Order (P)
902 Set_Reverse_Storage_Order (Base_Type (E));
908 if Is_Fixed_Point_Type (E)
909 and then not Has_Small_Clause (E)
911 Set_Small_Value (E, Small_Value (P));
916 when Aspect_Storage_Size =>
917 if (Is_Access_Type (E) or else Is_Task_Type (E))
918 and then not Has_Storage_Size_Clause (E)
920 Set_Storage_Size_Variable
921 (Base_Type (E), Storage_Size_Variable (P));
926 when Aspect_Value_Size =>
928 -- Value_Size is never inherited, it is either set by
929 -- default, or it is explicitly set for the derived
930 -- type. So nothing to do here.
936 when Aspect_Volatile =>
937 if Is_Volatile (P) then
941 -- Volatile_Components
943 when Aspect_Volatile_Components =>
944 if Has_Volatile_Components (P) then
945 Set_Has_Volatile_Components (Base_Type (E));
948 -- That should be all the Rep Aspects
951 pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect);
958 N := Next_Rep_Item (N);
960 end Inherit_Delayed_Rep_Aspects;
962 -------------------------------------
963 -- Make_Pragma_From_Boolean_Aspect --
964 -------------------------------------
966 procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is
967 Ident : constant Node_Id := Identifier (ASN);
968 A_Name : constant Name_Id := Chars (Ident);
969 A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name);
970 Ent : constant Entity_Id := Entity (ASN);
971 Expr : constant Node_Id := Expression (ASN);
972 Loc : constant Source_Ptr := Sloc (ASN);
976 procedure Check_False_Aspect_For_Derived_Type;
977 -- This procedure checks for the case of a false aspect for a derived
978 -- type, which improperly tries to cancel an aspect inherited from
981 -----------------------------------------
982 -- Check_False_Aspect_For_Derived_Type --
983 -----------------------------------------
985 procedure Check_False_Aspect_For_Derived_Type is
989 -- We are only checking derived types
991 if not Is_Derived_Type (E) then
995 Par := Nearest_Ancestor (E);
998 when Aspect_Atomic | Aspect_Shared =>
999 if not Is_Atomic (Par) then
1003 when Aspect_Atomic_Components =>
1004 if not Has_Atomic_Components (Par) then
1008 when Aspect_Discard_Names =>
1009 if not Discard_Names (Par) then
1014 if not Is_Packed (Par) then
1018 when Aspect_Unchecked_Union =>
1019 if not Is_Unchecked_Union (Par) then
1023 when Aspect_Volatile =>
1024 if not Is_Volatile (Par) then
1028 when Aspect_Volatile_Components =>
1029 if not Has_Volatile_Components (Par) then
1037 -- Fall through means we are canceling an inherited aspect
1039 Error_Msg_Name_1 := A_Name;
1041 ("derived type& inherits aspect%, cannot cancel", Expr, E);
1043 end Check_False_Aspect_For_Derived_Type;
1045 -- Start of processing for Make_Pragma_From_Boolean_Aspect
1048 -- Note that we know Expr is present, because for a missing Expr
1049 -- argument, we knew it was True and did not need to delay the
1050 -- evaluation to the freeze point.
1052 if Is_False (Static_Boolean (Expr)) then
1053 Check_False_Aspect_For_Derived_Type;
1058 Pragma_Argument_Associations => New_List (
1059 Make_Pragma_Argument_Association (Sloc (Ident),
1060 Expression => New_Occurrence_Of (Ent, Sloc (Ident)))),
1062 Pragma_Identifier =>
1063 Make_Identifier (Sloc (Ident), Chars (Ident)));
1065 Set_From_Aspect_Specification (Prag, True);
1066 Set_Corresponding_Aspect (Prag, ASN);
1067 Set_Aspect_Rep_Item (ASN, Prag);
1068 Set_Is_Delayed_Aspect (Prag);
1069 Set_Parent (Prag, ASN);
1071 end Make_Pragma_From_Boolean_Aspect;
1073 -- Start of processing for Analyze_Aspects_At_Freeze_Point
1076 -- Must be visible in current scope
1078 if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then
1082 -- Look for aspect specification entries for this entity
1084 ASN := First_Rep_Item (E);
1085 while Present (ASN) loop
1086 if Nkind (ASN) = N_Aspect_Specification then
1087 exit when Entity (ASN) /= E;
1089 if Is_Delayed_Aspect (ASN) then
1090 A_Id := Get_Aspect_Id (ASN);
1094 -- For aspects whose expression is an optional Boolean, make
1095 -- the corresponding pragma at the freezing point.
1097 when Boolean_Aspects |
1098 Library_Unit_Aspects =>
1099 Make_Pragma_From_Boolean_Aspect (ASN);
1101 -- Special handling for aspects that don't correspond to
1102 -- pragmas/attributes.
1104 when Aspect_Default_Value |
1105 Aspect_Default_Component_Value =>
1106 Analyze_Aspect_Default_Value (ASN);
1108 -- Ditto for iterator aspects, because the corresponding
1109 -- attributes may not have been analyzed yet.
1111 when Aspect_Constant_Indexing |
1112 Aspect_Variable_Indexing |
1113 Aspect_Default_Iterator |
1114 Aspect_Iterator_Element =>
1115 Analyze (Expression (ASN));
1121 Ritem := Aspect_Rep_Item (ASN);
1123 if Present (Ritem) then
1129 Next_Rep_Item (ASN);
1132 -- This is where we inherit delayed rep aspects from our parent. Note
1133 -- that if we fell out of the above loop with ASN non-empty, it means
1134 -- we hit an aspect for an entity other than E, and it must be the
1135 -- type from which we were derived.
1137 if May_Inherit_Delayed_Rep_Aspects (E) then
1138 Inherit_Delayed_Rep_Aspects (ASN);
1140 end Analyze_Aspects_At_Freeze_Point;
1142 -----------------------------------
1143 -- Analyze_Aspect_Specifications --
1144 -----------------------------------
1146 procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is
1147 procedure Decorate_Delayed_Aspect_And_Pragma
1150 -- Establish the linkages between a delayed aspect and its corresponding
1151 -- pragma. Set all delay-related flags on both constructs.
1153 procedure Insert_Delayed_Pragma (Prag : Node_Id);
1154 -- Insert a postcondition-like pragma into the tree depending on the
1155 -- context. Prag must denote one of the following: Pre, Post, Depends,
1156 -- Global or Contract_Cases.
1158 ----------------------------------------
1159 -- Decorate_Delayed_Aspect_And_Pragma --
1160 ----------------------------------------
1162 procedure Decorate_Delayed_Aspect_And_Pragma
1167 Set_Aspect_Rep_Item (Asp, Prag);
1168 Set_Corresponding_Aspect (Prag, Asp);
1169 Set_From_Aspect_Specification (Prag);
1170 Set_Is_Delayed_Aspect (Prag);
1171 Set_Is_Delayed_Aspect (Asp);
1172 Set_Parent (Prag, Asp);
1173 end Decorate_Delayed_Aspect_And_Pragma;
1175 ---------------------------
1176 -- Insert_Delayed_Pragma --
1177 ---------------------------
1179 procedure Insert_Delayed_Pragma (Prag : Node_Id) is
1183 -- When the context is a library unit, the pragma is added to the
1184 -- Pragmas_After list.
1186 if Nkind (Parent (N)) = N_Compilation_Unit then
1187 Aux := Aux_Decls_Node (Parent (N));
1189 if No (Pragmas_After (Aux)) then
1190 Set_Pragmas_After (Aux, New_List);
1193 Prepend (Prag, Pragmas_After (Aux));
1195 -- Pragmas associated with subprogram bodies are inserted in the
1196 -- declarative part.
1198 elsif Nkind (N) = N_Subprogram_Body then
1199 if No (Declarations (N)) then
1200 Set_Declarations (N, New_List (Prag));
1206 -- There may be several aspects associated with the body;
1207 -- preserve the ordering of the corresponding pragmas.
1209 D := First (Declarations (N));
1210 while Present (D) loop
1211 exit when Nkind (D) /= N_Pragma
1212 or else not From_Aspect_Specification (D);
1217 Append (Prag, Declarations (N));
1219 Insert_Before (D, Prag);
1227 Insert_After (N, Prag);
1229 -- Analyze the pragma before analyzing the proper body of a stub.
1230 -- This ensures that the pragma will appear on the proper contract
1231 -- list (see N_Contract).
1233 if Nkind (N) = N_Subprogram_Body_Stub then
1237 end Insert_Delayed_Pragma;
1245 L : constant List_Id := Aspect_Specifications (N);
1247 Ins_Node : Node_Id := N;
1248 -- Insert pragmas/attribute definition clause after this node when no
1249 -- delayed analysis is required.
1251 -- Start of processing for Analyze_Aspect_Specifications
1253 -- The general processing involves building an attribute definition
1254 -- clause or a pragma node that corresponds to the aspect. Then in order
1255 -- to delay the evaluation of this aspect to the freeze point, we attach
1256 -- the corresponding pragma/attribute definition clause to the aspect
1257 -- specification node, which is then placed in the Rep Item chain. In
1258 -- this case we mark the entity by setting the flag Has_Delayed_Aspects
1259 -- and we evaluate the rep item at the freeze point. When the aspect
1260 -- doesn't have a corresponding pragma/attribute definition clause, then
1261 -- its analysis is simply delayed at the freeze point.
1263 -- Some special cases don't require delay analysis, thus the aspect is
1264 -- analyzed right now.
1266 -- Note that there is a special handling for Pre, Post, Test_Case,
1267 -- Contract_Cases aspects. In these cases, we do not have to worry
1268 -- about delay issues, since the pragmas themselves deal with delay
1269 -- of visibility for the expression analysis. Thus, we just insert
1270 -- the pragma after the node N.
1273 pragma Assert (Present (L));
1275 -- Loop through aspects
1277 Aspect := First (L);
1278 Aspect_Loop : while Present (Aspect) loop
1279 Analyze_One_Aspect : declare
1280 Expr : constant Node_Id := Expression (Aspect);
1281 Id : constant Node_Id := Identifier (Aspect);
1282 Loc : constant Source_Ptr := Sloc (Aspect);
1283 Nam : constant Name_Id := Chars (Id);
1284 A_Id : constant Aspect_Id := Get_Aspect_Id (Nam);
1287 Delay_Required : Boolean;
1288 -- Set False if delay is not required
1290 Eloc : Source_Ptr := No_Location;
1291 -- Source location of expression, modified when we split PPC's. It
1292 -- is set below when Expr is present.
1294 procedure Analyze_Aspect_External_Or_Link_Name;
1295 -- Perform analysis of the External_Name or Link_Name aspects
1297 procedure Analyze_Aspect_Implicit_Dereference;
1298 -- Perform analysis of the Implicit_Dereference aspects
1300 procedure Make_Aitem_Pragma
1301 (Pragma_Argument_Associations : List_Id;
1302 Pragma_Name : Name_Id);
1303 -- This is a wrapper for Make_Pragma used for converting aspects
1304 -- to pragmas. It takes care of Sloc (set from Loc) and building
1305 -- the pragma identifier from the given name. In addition the
1306 -- flags Class_Present and Split_PPC are set from the aspect
1307 -- node, as well as Is_Ignored. This routine also sets the
1308 -- From_Aspect_Specification in the resulting pragma node to
1309 -- True, and sets Corresponding_Aspect to point to the aspect.
1310 -- The resulting pragma is assigned to Aitem.
1312 ------------------------------------------
1313 -- Analyze_Aspect_External_Or_Link_Name --
1314 ------------------------------------------
1316 procedure Analyze_Aspect_External_Or_Link_Name is
1318 -- Verify that there is an Import/Export aspect defined for the
1319 -- entity. The processing of that aspect in turn checks that
1320 -- there is a Convention aspect declared. The pragma is
1321 -- constructed when processing the Convention aspect.
1328 while Present (A) loop
1329 exit when Nam_In (Chars (Identifier (A)), Name_Export,
1336 ("missing Import/Export for Link/External name",
1340 end Analyze_Aspect_External_Or_Link_Name;
1342 -----------------------------------------
1343 -- Analyze_Aspect_Implicit_Dereference --
1344 -----------------------------------------
1346 procedure Analyze_Aspect_Implicit_Dereference is
1348 if not Is_Type (E) or else not Has_Discriminants (E) then
1350 ("aspect must apply to a type with discriminants", N);
1357 Disc := First_Discriminant (E);
1358 while Present (Disc) loop
1359 if Chars (Expr) = Chars (Disc)
1360 and then Ekind (Etype (Disc)) =
1361 E_Anonymous_Access_Type
1363 Set_Has_Implicit_Dereference (E);
1364 Set_Has_Implicit_Dereference (Disc);
1368 Next_Discriminant (Disc);
1371 -- Error if no proper access discriminant.
1374 ("not an access discriminant of&", Expr, E);
1377 end Analyze_Aspect_Implicit_Dereference;
1379 -----------------------
1380 -- Make_Aitem_Pragma --
1381 -----------------------
1383 procedure Make_Aitem_Pragma
1384 (Pragma_Argument_Associations : List_Id;
1385 Pragma_Name : Name_Id)
1387 Args : List_Id := Pragma_Argument_Associations;
1390 -- We should never get here if aspect was disabled
1392 pragma Assert (not Is_Disabled (Aspect));
1394 -- Certain aspects allow for an optional name or expression. Do
1395 -- not generate a pragma with empty argument association list.
1397 if No (Args) or else No (Expression (First (Args))) then
1405 Pragma_Argument_Associations => Args,
1406 Pragma_Identifier =>
1407 Make_Identifier (Sloc (Id), Pragma_Name),
1408 Class_Present => Class_Present (Aspect),
1409 Split_PPC => Split_PPC (Aspect));
1411 -- Set additional semantic fields
1413 if Is_Ignored (Aspect) then
1414 Set_Is_Ignored (Aitem);
1415 elsif Is_Checked (Aspect) then
1416 Set_Is_Checked (Aitem);
1419 Set_Corresponding_Aspect (Aitem, Aspect);
1420 Set_From_Aspect_Specification (Aitem, True);
1421 end Make_Aitem_Pragma;
1423 -- Start of processing for Analyze_One_Aspect
1426 -- Skip aspect if already analyzed (not clear if this is needed)
1428 if Analyzed (Aspect) then
1432 -- Skip looking at aspect if it is totally disabled. Just mark it
1433 -- as such for later reference in the tree. This also sets the
1434 -- Is_Ignored and Is_Checked flags appropriately.
1436 Check_Applicable_Policy (Aspect);
1438 if Is_Disabled (Aspect) then
1442 -- Set the source location of expression, used in the case of
1443 -- a failed precondition/postcondition or invariant. Note that
1444 -- the source location of the expression is not usually the best
1445 -- choice here. For example, it gets located on the last AND
1446 -- keyword in a chain of boolean expressiond AND'ed together.
1447 -- It is best to put the message on the first character of the
1448 -- assertion, which is the effect of the First_Node call here.
1450 if Present (Expr) then
1451 Eloc := Sloc (First_Node (Expr));
1454 -- Check restriction No_Implementation_Aspect_Specifications
1456 if Implementation_Defined_Aspect (A_Id) then
1458 (No_Implementation_Aspect_Specifications, Aspect);
1461 -- Check restriction No_Specification_Of_Aspect
1463 Check_Restriction_No_Specification_Of_Aspect (Aspect);
1465 -- Analyze this aspect (actual analysis is delayed till later)
1467 Set_Analyzed (Aspect);
1468 Set_Entity (Aspect, E);
1469 Ent := New_Occurrence_Of (E, Sloc (Id));
1471 -- Check for duplicate aspect. Note that the Comes_From_Source
1472 -- test allows duplicate Pre/Post's that we generate internally
1473 -- to escape being flagged here.
1475 if No_Duplicates_Allowed (A_Id) then
1477 while Anod /= Aspect loop
1478 if Comes_From_Source (Aspect)
1479 and then Same_Aspect (A_Id, Get_Aspect_Id (Anod))
1481 Error_Msg_Name_1 := Nam;
1482 Error_Msg_Sloc := Sloc (Anod);
1484 -- Case of same aspect specified twice
1486 if Class_Present (Anod) = Class_Present (Aspect) then
1487 if not Class_Present (Anod) then
1489 ("aspect% for & previously given#",
1493 ("aspect `%''Class` for & previously given#",
1503 -- Check some general restrictions on language defined aspects
1505 if not Implementation_Defined_Aspect (A_Id) then
1506 Error_Msg_Name_1 := Nam;
1508 -- Not allowed for renaming declarations
1510 if Nkind (N) in N_Renaming_Declaration then
1512 ("aspect % not allowed for renaming declaration",
1516 -- Not allowed for formal type declarations
1518 if Nkind (N) = N_Formal_Type_Declaration then
1520 ("aspect % not allowed for formal type declaration",
1525 -- Copy expression for later processing by the procedures
1526 -- Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
1528 Set_Entity (Id, New_Copy_Tree (Expr));
1530 -- Set Delay_Required as appropriate to aspect
1532 case Aspect_Delay (A_Id) is
1533 when Always_Delay =>
1534 Delay_Required := True;
1537 Delay_Required := False;
1541 -- If expression has the form of an integer literal, then
1542 -- do not delay, since we know the value cannot change.
1543 -- This optimization catches most rep clause cases.
1545 if (Present (Expr) and then Nkind (Expr) = N_Integer_Literal)
1546 or else (A_Id in Boolean_Aspects and then No (Expr))
1548 Delay_Required := False;
1550 Delay_Required := True;
1551 Set_Has_Delayed_Rep_Aspects (E);
1555 -- Processing based on specific aspect
1559 -- No_Aspect should be impossible
1562 raise Program_Error;
1564 -- Case 1: Aspects corresponding to attribute definition
1567 when Aspect_Address |
1570 Aspect_Component_Size |
1571 Aspect_Constant_Indexing |
1572 Aspect_Default_Iterator |
1573 Aspect_Dispatching_Domain |
1574 Aspect_External_Tag |
1576 Aspect_Iterator_Element |
1577 Aspect_Machine_Radix |
1578 Aspect_Object_Size |
1581 Aspect_Scalar_Storage_Order |
1584 Aspect_Simple_Storage_Pool |
1585 Aspect_Storage_Pool |
1586 Aspect_Stream_Size |
1588 Aspect_Variable_Indexing |
1591 -- Indexing aspects apply only to tagged type
1593 if (A_Id = Aspect_Constant_Indexing
1595 A_Id = Aspect_Variable_Indexing)
1596 and then not (Is_Type (E)
1597 and then Is_Tagged_Type (E))
1599 Error_Msg_N ("indexing applies to a tagged type", N);
1603 -- For case of address aspect, we don't consider that we
1604 -- know the entity is never set in the source, since it is
1605 -- is likely aliasing is occurring.
1607 -- Note: one might think that the analysis of the resulting
1608 -- attribute definition clause would take care of that, but
1609 -- that's not the case since it won't be from source.
1611 if A_Id = Aspect_Address then
1612 Set_Never_Set_In_Source (E, False);
1615 -- Construct the attribute definition clause
1618 Make_Attribute_Definition_Clause (Loc,
1620 Chars => Chars (Id),
1621 Expression => Relocate_Node (Expr));
1623 -- If the address is specified, then we treat the entity as
1624 -- referenced, to avoid spurious warnings. This is analogous
1625 -- to what is done with an attribute definition clause, but
1626 -- here we don't want to generate a reference because this
1627 -- is the point of definition of the entity.
1629 if A_Id = Aspect_Address then
1633 -- Case 2: Aspects corresponding to pragmas
1635 -- Case 2a: Aspects corresponding to pragmas with two
1636 -- arguments, where the first argument is a local name
1637 -- referring to the entity, and the second argument is the
1638 -- aspect definition expression.
1640 -- Suppress/Unsuppress
1642 when Aspect_Suppress |
1643 Aspect_Unsuppress =>
1646 (Pragma_Argument_Associations => New_List (
1647 Make_Pragma_Argument_Association (Loc,
1648 Expression => New_Occurrence_Of (E, Loc)),
1649 Make_Pragma_Argument_Association (Sloc (Expr),
1650 Expression => Relocate_Node (Expr))),
1651 Pragma_Name => Chars (Id));
1655 -- Corresponds to pragma Implemented, construct the pragma
1657 when Aspect_Synchronization =>
1660 (Pragma_Argument_Associations => New_List (
1661 Make_Pragma_Argument_Association (Loc,
1662 Expression => New_Occurrence_Of (E, Loc)),
1663 Make_Pragma_Argument_Association (Sloc (Expr),
1664 Expression => Relocate_Node (Expr))),
1665 Pragma_Name => Name_Implemented);
1669 when Aspect_Attach_Handler =>
1671 (Pragma_Argument_Associations => New_List (
1672 Make_Pragma_Argument_Association (Sloc (Ent),
1674 Make_Pragma_Argument_Association (Sloc (Expr),
1675 Expression => Relocate_Node (Expr))),
1676 Pragma_Name => Name_Attach_Handler);
1678 -- Dynamic_Predicate, Predicate, Static_Predicate
1680 when Aspect_Dynamic_Predicate |
1682 Aspect_Static_Predicate =>
1684 -- Construct the pragma (always a pragma Predicate, with
1685 -- flags recording whether it is static/dynamic). We also
1686 -- set flags recording this in the type itself.
1689 (Pragma_Argument_Associations => New_List (
1690 Make_Pragma_Argument_Association (Sloc (Ent),
1692 Make_Pragma_Argument_Association (Sloc (Expr),
1693 Expression => Relocate_Node (Expr))),
1694 Pragma_Name => Name_Predicate);
1696 -- Mark type has predicates, and remember what kind of
1697 -- aspect lead to this predicate (we need this to access
1698 -- the right set of check policies later on).
1700 Set_Has_Predicates (E);
1702 if A_Id = Aspect_Dynamic_Predicate then
1703 Set_Has_Dynamic_Predicate_Aspect (E);
1704 elsif A_Id = Aspect_Static_Predicate then
1705 Set_Has_Static_Predicate_Aspect (E);
1708 -- If the type is private, indicate that its completion
1709 -- has a freeze node, because that is the one that will be
1710 -- visible at freeze time.
1712 if Is_Private_Type (E) and then Present (Full_View (E)) then
1713 Set_Has_Predicates (Full_View (E));
1715 if A_Id = Aspect_Dynamic_Predicate then
1716 Set_Has_Dynamic_Predicate_Aspect (Full_View (E));
1717 elsif A_Id = Aspect_Static_Predicate then
1718 Set_Has_Static_Predicate_Aspect (Full_View (E));
1721 Set_Has_Delayed_Aspects (Full_View (E));
1722 Ensure_Freeze_Node (Full_View (E));
1725 -- Case 2b: Aspects corresponding to pragmas with two
1726 -- arguments, where the second argument is a local name
1727 -- referring to the entity, and the first argument is the
1728 -- aspect definition expression.
1732 when Aspect_Convention =>
1734 -- The aspect may be part of the specification of an import
1735 -- or export pragma. Scan the aspect list to gather the
1736 -- other components, if any. The name of the generated
1737 -- pragma is one of Convention/Import/Export.
1749 P_Name := Chars (Id);
1751 Arg_List := New_List;
1756 while Present (A) loop
1757 A_Name := Chars (Identifier (A));
1759 if Nam_In (A_Name, Name_Import, Name_Export) then
1761 Error_Msg_N ("conflicting", A);
1768 elsif A_Name = Name_Link_Name then
1770 Make_Pragma_Argument_Association (Loc,
1772 Expression => Relocate_Node (Expression (A)));
1774 elsif A_Name = Name_External_Name then
1776 Make_Pragma_Argument_Association (Loc,
1778 Expression => Relocate_Node (Expression (A)));
1784 Arg_List := New_List (
1785 Make_Pragma_Argument_Association (Sloc (Expr),
1786 Expression => Relocate_Node (Expr)),
1787 Make_Pragma_Argument_Association (Sloc (Ent),
1788 Expression => Ent));
1790 if Present (L_Assoc) then
1791 Append_To (Arg_List, L_Assoc);
1794 if Present (E_Assoc) then
1795 Append_To (Arg_List, E_Assoc);
1799 (Pragma_Argument_Associations => Arg_List,
1800 Pragma_Name => P_Name);
1803 -- CPU, Interrupt_Priority, Priority
1805 -- These three aspects can be specified for a subprogram body,
1806 -- in which case we generate pragmas for them and insert them
1807 -- ahead of local declarations, rather than after the body.
1810 Aspect_Interrupt_Priority |
1813 if Nkind (N) = N_Subprogram_Body then
1815 (Pragma_Argument_Associations => New_List (
1816 Make_Pragma_Argument_Association (Sloc (Expr),
1817 Expression => Relocate_Node (Expr))),
1818 Pragma_Name => Chars (Id));
1822 Make_Attribute_Definition_Clause (Loc,
1824 Chars => Chars (Id),
1825 Expression => Relocate_Node (Expr));
1830 when Aspect_Warnings =>
1832 (Pragma_Argument_Associations => New_List (
1833 Make_Pragma_Argument_Association (Sloc (Expr),
1834 Expression => Relocate_Node (Expr)),
1835 Make_Pragma_Argument_Association (Loc,
1836 Expression => New_Occurrence_Of (E, Loc))),
1837 Pragma_Name => Chars (Id));
1839 -- Case 2c: Aspects corresponding to pragmas with three
1842 -- Invariant aspects have a first argument that references the
1843 -- entity, a second argument that is the expression and a third
1844 -- argument that is an appropriate message.
1846 -- Invariant, Type_Invariant
1848 when Aspect_Invariant |
1849 Aspect_Type_Invariant =>
1851 -- Analysis of the pragma will verify placement legality:
1852 -- an invariant must apply to a private type, or appear in
1853 -- the private part of a spec and apply to a completion.
1856 (Pragma_Argument_Associations => New_List (
1857 Make_Pragma_Argument_Association (Sloc (Ent),
1859 Make_Pragma_Argument_Association (Sloc (Expr),
1860 Expression => Relocate_Node (Expr))),
1861 Pragma_Name => Name_Invariant);
1863 -- Add message unless exception messages are suppressed
1865 if not Opt.Exception_Locations_Suppressed then
1866 Append_To (Pragma_Argument_Associations (Aitem),
1867 Make_Pragma_Argument_Association (Eloc,
1868 Chars => Name_Message,
1870 Make_String_Literal (Eloc,
1871 Strval => "failed invariant from "
1872 & Build_Location_String (Eloc))));
1875 -- For Invariant case, insert immediately after the entity
1876 -- declaration. We do not have to worry about delay issues
1877 -- since the pragma processing takes care of this.
1879 Delay_Required := False;
1881 -- Case 2d : Aspects that correspond to a pragma with one
1886 when Aspect_Abstract_State => Abstract_State : declare
1891 -- Aspect Abstract_State introduces implicit declarations
1892 -- for all state abstraction entities it defines. To emulate
1893 -- this behavior, insert the pragma at the beginning of the
1894 -- visible declarations of the related package so that it is
1895 -- analyzed immediately.
1897 if Nkind_In (N, N_Generic_Package_Declaration,
1898 N_Package_Declaration)
1900 Spec := Specification (N);
1901 Decls := Visible_Declarations (Spec);
1904 (Pragma_Argument_Associations => New_List (
1905 Make_Pragma_Argument_Association (Loc,
1906 Expression => Relocate_Node (Expr))),
1907 Pragma_Name => Name_Abstract_State);
1908 Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem);
1912 Set_Visible_Declarations (N, Decls);
1915 Prepend_To (Decls, Aitem);
1919 ("aspect & must apply to a package declaration",
1928 -- Aspect Depends must be delayed because it mentions names
1929 -- of inputs and output that are classified by aspect Global.
1930 -- The aspect and pragma are treated the same way as a post
1933 when Aspect_Depends =>
1935 (Pragma_Argument_Associations => New_List (
1936 Make_Pragma_Argument_Association (Loc,
1937 Expression => Relocate_Node (Expr))),
1938 Pragma_Name => Name_Depends);
1940 Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem);
1941 Insert_Delayed_Pragma (Aitem);
1946 -- Aspect Global must be delayed because it can mention names
1947 -- and benefit from the forward visibility rules applicable to
1948 -- aspects of subprograms. The aspect and pragma are treated
1949 -- the same way as a post condition.
1951 when Aspect_Global =>
1953 (Pragma_Argument_Associations => New_List (
1954 Make_Pragma_Argument_Association (Loc,
1955 Expression => Relocate_Node (Expr))),
1956 Pragma_Name => Name_Global);
1958 Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem);
1959 Insert_Delayed_Pragma (Aitem);
1964 when Aspect_SPARK_Mode =>
1966 (Pragma_Argument_Associations => New_List (
1967 Make_Pragma_Argument_Association (Loc,
1968 Expression => Relocate_Node (Expr))),
1969 Pragma_Name => Name_SPARK_Mode);
1973 -- ??? To be implemented
1975 when Aspect_Refined_Depends =>
1980 -- ??? To be implemented
1982 when Aspect_Refined_Global =>
1987 when Aspect_Refined_Post =>
1989 (Pragma_Argument_Associations => New_List (
1990 Make_Pragma_Argument_Association (Loc,
1991 Expression => Relocate_Node (Expr))),
1992 Pragma_Name => Name_Refined_Post);
1996 when Aspect_Refined_Pre =>
1998 (Pragma_Argument_Associations => New_List (
1999 Make_Pragma_Argument_Association (Loc,
2000 Expression => Relocate_Node (Expr))),
2001 Pragma_Name => Name_Refined_Pre);
2005 when Aspect_Refined_State => Refined_State : declare
2009 -- The corresponding pragma for Refined_State is inserted in
2010 -- the declarations of the related package body. This action
2011 -- synchronizes both the source and from-aspect versions of
2014 if Nkind (N) = N_Package_Body then
2015 Decls := Declarations (N);
2018 (Pragma_Argument_Associations => New_List (
2019 Make_Pragma_Argument_Association (Loc,
2020 Expression => Relocate_Node (Expr))),
2021 Pragma_Name => Name_Refined_State);
2022 Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem);
2026 Set_Declarations (N, Decls);
2029 Prepend_To (Decls, Aitem);
2033 ("aspect & must apply to a package body", Aspect, Id);
2039 -- Relative_Deadline
2041 when Aspect_Relative_Deadline =>
2043 (Pragma_Argument_Associations => New_List (
2044 Make_Pragma_Argument_Association (Loc,
2045 Expression => Relocate_Node (Expr))),
2046 Pragma_Name => Name_Relative_Deadline);
2048 -- If the aspect applies to a task, the corresponding pragma
2049 -- must appear within its declarations, not after.
2051 if Nkind (N) = N_Task_Type_Declaration then
2057 if No (Task_Definition (N)) then
2058 Set_Task_Definition (N,
2059 Make_Task_Definition (Loc,
2060 Visible_Declarations => New_List,
2061 End_Label => Empty));
2064 Def := Task_Definition (N);
2065 V := Visible_Declarations (Def);
2066 if not Is_Empty_List (V) then
2067 Insert_Before (First (V), Aitem);
2070 Set_Visible_Declarations (Def, New_List (Aitem));
2077 -- Case 3 : Aspects that don't correspond to pragma/attribute
2078 -- definition clause.
2080 -- Case 3a: The aspects listed below don't correspond to
2081 -- pragmas/attributes but do require delayed analysis.
2083 -- Default_Value, Default_Component_Value
2085 when Aspect_Default_Value |
2086 Aspect_Default_Component_Value =>
2089 -- Case 3b: The aspects listed below don't correspond to
2090 -- pragmas/attributes and don't need delayed analysis.
2092 -- Implicit_Dereference
2094 -- For Implicit_Dereference, External_Name and Link_Name, only
2095 -- the legality checks are done during the analysis, thus no
2096 -- delay is required.
2098 when Aspect_Implicit_Dereference =>
2099 Analyze_Aspect_Implicit_Dereference;
2102 -- External_Name, Link_Name
2104 when Aspect_External_Name |
2106 Analyze_Aspect_External_Or_Link_Name;
2111 when Aspect_Dimension =>
2112 Analyze_Aspect_Dimension (N, Id, Expr);
2117 when Aspect_Dimension_System =>
2118 Analyze_Aspect_Dimension_System (N, Id, Expr);
2121 -- Case 4: Aspects requiring special handling
2123 -- Pre/Post/Test_Case/Contract_Cases whose corresponding
2124 -- pragmas take care of the delay.
2128 -- Aspects Pre/Post generate Precondition/Postcondition pragmas
2129 -- with a first argument that is the expression, and a second
2130 -- argument that is an informative message if the test fails.
2131 -- This is inserted right after the declaration, to get the
2132 -- required pragma placement. The processing for the pragmas
2133 -- takes care of the required delay.
2135 when Pre_Post_Aspects => Pre_Post : declare
2139 if A_Id = Aspect_Pre or else A_Id = Aspect_Precondition then
2140 Pname := Name_Precondition;
2142 Pname := Name_Postcondition;
2145 -- If the expressions is of the form A and then B, then
2146 -- we generate separate Pre/Post aspects for the separate
2147 -- clauses. Since we allow multiple pragmas, there is no
2148 -- problem in allowing multiple Pre/Post aspects internally.
2149 -- These should be treated in reverse order (B first and
2150 -- A second) since they are later inserted just after N in
2151 -- the order they are treated. This way, the pragma for A
2152 -- ends up preceding the pragma for B, which may have an
2153 -- importance for the error raised (either constraint error
2154 -- or precondition error).
2156 -- We do not do this for Pre'Class, since we have to put
2157 -- these conditions together in a complex OR expression
2159 -- We do not do this in ASIS mode, as ASIS relies on the
2160 -- original node representing the complete expression, when
2161 -- retrieving it through the source aspect table.
2164 and then (Pname = Name_Postcondition
2165 or else not Class_Present (Aspect))
2167 while Nkind (Expr) = N_And_Then loop
2168 Insert_After (Aspect,
2169 Make_Aspect_Specification (Sloc (Left_Opnd (Expr)),
2170 Identifier => Identifier (Aspect),
2171 Expression => Relocate_Node (Left_Opnd (Expr)),
2172 Class_Present => Class_Present (Aspect),
2173 Split_PPC => True));
2174 Rewrite (Expr, Relocate_Node (Right_Opnd (Expr)));
2175 Eloc := Sloc (Expr);
2179 -- Build the precondition/postcondition pragma
2181 -- Add note about why we do NOT need Copy_Tree here ???
2184 (Pragma_Argument_Associations => New_List (
2185 Make_Pragma_Argument_Association (Eloc,
2186 Chars => Name_Check,
2187 Expression => Relocate_Node (Expr))),
2188 Pragma_Name => Pname);
2190 -- Add message unless exception messages are suppressed
2192 if not Opt.Exception_Locations_Suppressed then
2193 Append_To (Pragma_Argument_Associations (Aitem),
2194 Make_Pragma_Argument_Association (Eloc,
2195 Chars => Name_Message,
2197 Make_String_Literal (Eloc,
2199 & Get_Name_String (Pname)
2201 & Build_Location_String (Eloc))));
2204 Set_Is_Delayed_Aspect (Aspect);
2206 -- For Pre/Post cases, insert immediately after the entity
2207 -- declaration, since that is the required pragma placement.
2208 -- Note that for these aspects, we do not have to worry
2209 -- about delay issues, since the pragmas themselves deal
2210 -- with delay of visibility for the expression analysis.
2212 Insert_Delayed_Pragma (Aitem);
2218 when Aspect_Test_Case => Test_Case : declare
2220 Comp_Expr : Node_Id;
2221 Comp_Assn : Node_Id;
2227 if Nkind (Parent (N)) = N_Compilation_Unit then
2228 Error_Msg_Name_1 := Nam;
2229 Error_Msg_N ("incorrect placement of aspect `%`", E);
2233 if Nkind (Expr) /= N_Aggregate then
2234 Error_Msg_Name_1 := Nam;
2236 ("wrong syntax for aspect `%` for &", Id, E);
2240 -- Make pragma expressions refer to the original aspect
2241 -- expressions through the Original_Node link. This is
2242 -- used in semantic analysis for ASIS mode, so that the
2243 -- original expression also gets analyzed.
2245 Comp_Expr := First (Expressions (Expr));
2246 while Present (Comp_Expr) loop
2247 New_Expr := Relocate_Node (Comp_Expr);
2248 Set_Original_Node (New_Expr, Comp_Expr);
2250 Make_Pragma_Argument_Association (Sloc (Comp_Expr),
2251 Expression => New_Expr));
2255 Comp_Assn := First (Component_Associations (Expr));
2256 while Present (Comp_Assn) loop
2257 if List_Length (Choices (Comp_Assn)) /= 1
2259 Nkind (First (Choices (Comp_Assn))) /= N_Identifier
2261 Error_Msg_Name_1 := Nam;
2263 ("wrong syntax for aspect `%` for &", Id, E);
2267 New_Expr := Relocate_Node (Expression (Comp_Assn));
2268 Set_Original_Node (New_Expr, Expression (Comp_Assn));
2270 Make_Pragma_Argument_Association (Sloc (Comp_Assn),
2271 Chars => Chars (First (Choices (Comp_Assn))),
2272 Expression => New_Expr));
2276 -- Build the test-case pragma
2279 (Pragma_Argument_Associations => Args,
2280 Pragma_Name => Nam);
2285 when Aspect_Contract_Cases =>
2287 (Pragma_Argument_Associations => New_List (
2288 Make_Pragma_Argument_Association (Loc,
2289 Expression => Relocate_Node (Expr))),
2290 Pragma_Name => Nam);
2292 Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem);
2293 Insert_Delayed_Pragma (Aitem);
2296 -- Case 5: Special handling for aspects with an optional
2297 -- boolean argument.
2299 -- In the general case, the corresponding pragma cannot be
2300 -- generated yet because the evaluation of the boolean needs
2301 -- to be delayed till the freeze point.
2303 when Boolean_Aspects |
2304 Library_Unit_Aspects =>
2306 Set_Is_Boolean_Aspect (Aspect);
2308 -- Lock_Free aspect only apply to protected objects
2310 if A_Id = Aspect_Lock_Free then
2311 if Ekind (E) /= E_Protected_Type then
2312 Error_Msg_Name_1 := Nam;
2314 ("aspect % only applies to a protected object",
2318 -- Set the Uses_Lock_Free flag to True if there is no
2319 -- expression or if the expression is True. The
2320 -- evaluation of this aspect should be delayed to the
2321 -- freeze point (why???)
2324 or else Is_True (Static_Boolean (Expr))
2326 Set_Uses_Lock_Free (E);
2329 Record_Rep_Item (E, Aspect);
2334 elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then
2336 -- Verify that there is an aspect Convention that will
2337 -- incorporate the Import/Export aspect, and eventual
2338 -- Link/External names.
2345 while Present (A) loop
2346 exit when Chars (Identifier (A)) = Name_Convention;
2350 -- It is legal to specify Import for a variable, in
2351 -- order to suppress initialization for it, without
2352 -- specifying explicitly its convention. However this
2353 -- is only legal if the convention of the object type
2354 -- is Ada or similar.
2357 if Ekind (E) = E_Variable
2358 and then A_Id = Aspect_Import
2361 C : constant Convention_Id :=
2362 Convention (Etype (E));
2364 if C = Convention_Ada or else
2365 C = Convention_Ada_Pass_By_Copy or else
2366 C = Convention_Ada_Pass_By_Reference
2373 -- Otherwise, Convention must be specified
2376 ("missing Convention aspect for Export/Import",
2384 -- Library unit aspects require special handling in the case
2385 -- of a package declaration, the pragma needs to be inserted
2386 -- in the list of declarations for the associated package.
2387 -- There is no issue of visibility delay for these aspects.
2389 if A_Id in Library_Unit_Aspects
2391 Nkind_In (N, N_Package_Declaration,
2392 N_Generic_Package_Declaration)
2393 and then Nkind (Parent (N)) /= N_Compilation_Unit
2396 ("incorrect context for library unit aspect&", Id);
2400 -- Cases where we do not delay, includes all cases where
2401 -- the expression is missing other than the above cases.
2403 if not Delay_Required or else No (Expr) then
2405 (Pragma_Argument_Associations => New_List (
2406 Make_Pragma_Argument_Association (Sloc (Ent),
2407 Expression => Ent)),
2408 Pragma_Name => Chars (Id));
2409 Delay_Required := False;
2411 -- In general cases, the corresponding pragma/attribute
2412 -- definition clause will be inserted later at the freezing
2413 -- point, and we do not need to build it now
2421 -- This is special because for access types we need to generate
2422 -- an attribute definition clause. This also works for single
2423 -- task declarations, but it does not work for task type
2424 -- declarations, because we have the case where the expression
2425 -- references a discriminant of the task type. That can't use
2426 -- an attribute definition clause because we would not have
2427 -- visibility on the discriminant. For that case we must
2428 -- generate a pragma in the task definition.
2430 when Aspect_Storage_Size =>
2434 if Ekind (E) = E_Task_Type then
2436 Decl : constant Node_Id := Declaration_Node (E);
2439 pragma Assert (Nkind (Decl) = N_Task_Type_Declaration);
2441 -- If no task definition, create one
2443 if No (Task_Definition (Decl)) then
2444 Set_Task_Definition (Decl,
2445 Make_Task_Definition (Loc,
2446 Visible_Declarations => Empty_List,
2447 End_Label => Empty));
2450 -- Create a pragma and put it at the start of the
2451 -- task definition for the task type declaration.
2454 (Pragma_Argument_Associations => New_List (
2455 Make_Pragma_Argument_Association (Loc,
2456 Expression => Relocate_Node (Expr))),
2457 Pragma_Name => Name_Storage_Size);
2461 Visible_Declarations (Task_Definition (Decl)));
2465 -- All other cases, generate attribute definition
2469 Make_Attribute_Definition_Clause (Loc,
2471 Chars => Chars (Id),
2472 Expression => Relocate_Node (Expr));
2476 -- Attach the corresponding pragma/attribute definition clause to
2477 -- the aspect specification node.
2479 if Present (Aitem) then
2480 Set_From_Aspect_Specification (Aitem, True);
2483 -- In the context of a compilation unit, we directly put the
2484 -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux
2485 -- node (no delay is required here) except for aspects on a
2486 -- subprogram body (see below) and a generic package, for which
2487 -- we need to introduce the pragma before building the generic
2488 -- copy (see sem_ch12), and for package instantiations, where
2489 -- the library unit pragmas are better handled early.
2491 if Nkind (Parent (N)) = N_Compilation_Unit
2492 and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect))
2495 Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
2498 pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux);
2500 -- For a Boolean aspect, create the corresponding pragma if
2501 -- no expression or if the value is True.
2503 if Is_Boolean_Aspect (Aspect) and then No (Aitem) then
2504 if Is_True (Static_Boolean (Expr)) then
2506 (Pragma_Argument_Associations => New_List (
2507 Make_Pragma_Argument_Association (Sloc (Ent),
2508 Expression => Ent)),
2509 Pragma_Name => Chars (Id));
2511 Set_From_Aspect_Specification (Aitem, True);
2512 Set_Corresponding_Aspect (Aitem, Aspect);
2519 -- If the aspect is on a subprogram body (relevant aspects
2520 -- are Inline and Priority), add the pragma in front of
2521 -- the declarations.
2523 if Nkind (N) = N_Subprogram_Body then
2524 if No (Declarations (N)) then
2525 Set_Declarations (N, New_List);
2528 Prepend (Aitem, Declarations (N));
2530 elsif Nkind (N) = N_Generic_Package_Declaration then
2531 if No (Visible_Declarations (Specification (N))) then
2532 Set_Visible_Declarations (Specification (N), New_List);
2536 Visible_Declarations (Specification (N)));
2538 elsif Nkind (N) = N_Package_Instantiation then
2540 Spec : constant Node_Id :=
2541 Specification (Instance_Spec (N));
2543 if No (Visible_Declarations (Spec)) then
2544 Set_Visible_Declarations (Spec, New_List);
2547 Prepend (Aitem, Visible_Declarations (Spec));
2551 if No (Pragmas_After (Aux)) then
2552 Set_Pragmas_After (Aux, New_List);
2555 Append (Aitem, Pragmas_After (Aux));
2562 -- The evaluation of the aspect is delayed to the freezing point.
2563 -- The pragma or attribute clause if there is one is then attached
2564 -- to the aspect specification which is put in the rep item list.
2566 if Delay_Required then
2567 if Present (Aitem) then
2568 Set_Is_Delayed_Aspect (Aitem);
2569 Set_Aspect_Rep_Item (Aspect, Aitem);
2570 Set_Parent (Aitem, Aspect);
2573 Set_Is_Delayed_Aspect (Aspect);
2575 -- In the case of Default_Value, link the aspect to base type
2576 -- as well, even though it appears on a first subtype. This is
2577 -- mandated by the semantics of the aspect. Do not establish
2578 -- the link when processing the base type itself as this leads
2579 -- to a rep item circularity. Verify that we are dealing with
2580 -- a scalar type to prevent cascaded errors.
2582 if A_Id = Aspect_Default_Value
2583 and then Is_Scalar_Type (E)
2584 and then Base_Type (E) /= E
2586 Set_Has_Delayed_Aspects (Base_Type (E));
2587 Record_Rep_Item (Base_Type (E), Aspect);
2590 Set_Has_Delayed_Aspects (E);
2591 Record_Rep_Item (E, Aspect);
2593 -- When delay is not required and the context is a package or a
2594 -- subprogram body, insert the pragma in the body declarations.
2596 elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
2597 if No (Declarations (N)) then
2598 Set_Declarations (N, New_List);
2601 -- The pragma is added before source declarations
2603 Prepend_To (Declarations (N), Aitem);
2605 -- When delay is not required and the context is not a compilation
2606 -- unit, we simply insert the pragma/attribute definition clause
2610 Insert_After (Ins_Node, Aitem);
2613 end Analyze_One_Aspect;
2617 end loop Aspect_Loop;
2619 if Has_Delayed_Aspects (E) then
2620 Ensure_Freeze_Node (E);
2622 end Analyze_Aspect_Specifications;
2624 -----------------------
2625 -- Analyze_At_Clause --
2626 -----------------------
2628 -- An at clause is replaced by the corresponding Address attribute
2629 -- definition clause that is the preferred approach in Ada 95.
2631 procedure Analyze_At_Clause (N : Node_Id) is
2632 CS : constant Boolean := Comes_From_Source (N);
2635 -- This is an obsolescent feature
2637 Check_Restriction (No_Obsolescent_Features, N);
2639 if Warn_On_Obsolescent_Feature then
2641 ("?j?at clause is an obsolescent feature (RM J.7(2))", N);
2643 ("\?j?use address attribute definition clause instead", N);
2646 -- Rewrite as address clause
2649 Make_Attribute_Definition_Clause (Sloc (N),
2650 Name => Identifier (N),
2651 Chars => Name_Address,
2652 Expression => Expression (N)));
2654 -- We preserve Comes_From_Source, since logically the clause still comes
2655 -- from the source program even though it is changed in form.
2657 Set_Comes_From_Source (N, CS);
2659 -- Analyze rewritten clause
2661 Analyze_Attribute_Definition_Clause (N);
2662 end Analyze_At_Clause;
2664 -----------------------------------------
2665 -- Analyze_Attribute_Definition_Clause --
2666 -----------------------------------------
2668 procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is
2669 Loc : constant Source_Ptr := Sloc (N);
2670 Nam : constant Node_Id := Name (N);
2671 Attr : constant Name_Id := Chars (N);
2672 Expr : constant Node_Id := Expression (N);
2673 Id : constant Attribute_Id := Get_Attribute_Id (Attr);
2676 -- The entity of Nam after it is analyzed. In the case of an incomplete
2677 -- type, this is the underlying type.
2680 -- The underlying entity to which the attribute applies. Generally this
2681 -- is the Underlying_Type of Ent, except in the case where the clause
2682 -- applies to full view of incomplete type or private type in which case
2683 -- U_Ent is just a copy of Ent.
2685 FOnly : Boolean := False;
2686 -- Reset to True for subtype specific attribute (Alignment, Size)
2687 -- and for stream attributes, i.e. those cases where in the call
2688 -- to Rep_Item_Too_Late, FOnly is set True so that only the freezing
2689 -- rules are checked. Note that the case of stream attributes is not
2690 -- clear from the RM, but see AI95-00137. Also, the RM seems to
2691 -- disallow Storage_Size for derived task types, but that is also
2692 -- clearly unintentional.
2694 procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type);
2695 -- Common processing for 'Read, 'Write, 'Input and 'Output attribute
2696 -- definition clauses.
2698 function Duplicate_Clause return Boolean;
2699 -- This routine checks if the aspect for U_Ent being given by attribute
2700 -- definition clause N is for an aspect that has already been specified,
2701 -- and if so gives an error message. If there is a duplicate, True is
2702 -- returned, otherwise if there is no error, False is returned.
2704 procedure Check_Indexing_Functions;
2705 -- Check that the function in Constant_Indexing or Variable_Indexing
2706 -- attribute has the proper type structure. If the name is overloaded,
2707 -- check that some interpretation is legal.
2709 procedure Check_Iterator_Functions;
2710 -- Check that there is a single function in Default_Iterator attribute
2711 -- has the proper type structure.
2713 function Check_Primitive_Function (Subp : Entity_Id) return Boolean;
2714 -- Common legality check for the previous two
2716 -----------------------------------
2717 -- Analyze_Stream_TSS_Definition --
2718 -----------------------------------
2720 procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
2721 Subp : Entity_Id := Empty;
2726 Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
2727 -- True for Read attribute, false for other attributes
2729 function Has_Good_Profile (Subp : Entity_Id) return Boolean;
2730 -- Return true if the entity is a subprogram with an appropriate
2731 -- profile for the attribute being defined.
2733 ----------------------
2734 -- Has_Good_Profile --
2735 ----------------------
2737 function Has_Good_Profile (Subp : Entity_Id) return Boolean is
2739 Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input);
2740 Expected_Ekind : constant array (Boolean) of Entity_Kind :=
2741 (False => E_Procedure, True => E_Function);
2745 if Ekind (Subp) /= Expected_Ekind (Is_Function) then
2749 F := First_Formal (Subp);
2752 or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
2753 or else Designated_Type (Etype (F)) /=
2754 Class_Wide_Type (RTE (RE_Root_Stream_Type))
2759 if not Is_Function then
2763 Expected_Mode : constant array (Boolean) of Entity_Kind :=
2764 (False => E_In_Parameter,
2765 True => E_Out_Parameter);
2767 if Parameter_Mode (F) /= Expected_Mode (Is_Read) then
2775 Typ := Etype (Subp);
2778 return Base_Type (Typ) = Base_Type (Ent)
2779 and then No (Next_Formal (F));
2780 end Has_Good_Profile;
2782 -- Start of processing for Analyze_Stream_TSS_Definition
2787 if not Is_Type (U_Ent) then
2788 Error_Msg_N ("local name must be a subtype", Nam);
2792 Pnam := TSS (Base_Type (U_Ent), TSS_Nam);
2794 -- If Pnam is present, it can be either inherited from an ancestor
2795 -- type (in which case it is legal to redefine it for this type), or
2796 -- be a previous definition of the attribute for the same type (in
2797 -- which case it is illegal).
2799 -- In the first case, it will have been analyzed already, and we
2800 -- can check that its profile does not match the expected profile
2801 -- for a stream attribute of U_Ent. In the second case, either Pnam
2802 -- has been analyzed (and has the expected profile), or it has not
2803 -- been analyzed yet (case of a type that has not been frozen yet
2804 -- and for which the stream attribute has been set using Set_TSS).
2807 and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam))
2809 Error_Msg_Sloc := Sloc (Pnam);
2810 Error_Msg_Name_1 := Attr;
2811 Error_Msg_N ("% attribute already defined #", Nam);
2817 if Is_Entity_Name (Expr) then
2818 if not Is_Overloaded (Expr) then
2819 if Has_Good_Profile (Entity (Expr)) then
2820 Subp := Entity (Expr);
2824 Get_First_Interp (Expr, I, It);
2825 while Present (It.Nam) loop
2826 if Has_Good_Profile (It.Nam) then
2831 Get_Next_Interp (I, It);
2836 if Present (Subp) then
2837 if Is_Abstract_Subprogram (Subp) then
2838 Error_Msg_N ("stream subprogram must not be abstract", Expr);
2842 Set_Entity (Expr, Subp);
2843 Set_Etype (Expr, Etype (Subp));
2845 New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam);
2848 Error_Msg_Name_1 := Attr;
2849 Error_Msg_N ("incorrect expression for% attribute", Expr);
2851 end Analyze_Stream_TSS_Definition;
2853 ------------------------------
2854 -- Check_Indexing_Functions --
2855 ------------------------------
2857 procedure Check_Indexing_Functions is
2858 Indexing_Found : Boolean;
2860 procedure Check_One_Function (Subp : Entity_Id);
2861 -- Check one possible interpretation. Sets Indexing_Found True if an
2862 -- indexing function is found.
2864 ------------------------
2865 -- Check_One_Function --
2866 ------------------------
2868 procedure Check_One_Function (Subp : Entity_Id) is
2869 Default_Element : constant Node_Id :=
2870 Find_Value_Of_Aspect
2871 (Etype (First_Formal (Subp)),
2872 Aspect_Iterator_Element);
2875 if not Check_Primitive_Function (Subp)
2876 and then not Is_Overloaded (Expr)
2879 ("aspect Indexing requires a function that applies to type&",
2883 -- An indexing function must return either the default element of
2884 -- the container, or a reference type. For variable indexing it
2885 -- must be the latter.
2887 if Present (Default_Element) then
2888 Analyze (Default_Element);
2890 if Is_Entity_Name (Default_Element)
2891 and then Covers (Entity (Default_Element), Etype (Subp))
2893 Indexing_Found := True;
2898 -- For variable_indexing the return type must be a reference type
2900 if Attr = Name_Variable_Indexing
2901 and then not Has_Implicit_Dereference (Etype (Subp))
2904 ("function for indexing must return a reference type", Subp);
2907 Indexing_Found := True;
2909 end Check_One_Function;
2911 -- Start of processing for Check_Indexing_Functions
2920 if not Is_Overloaded (Expr) then
2921 Check_One_Function (Entity (Expr));
2929 Indexing_Found := False;
2930 Get_First_Interp (Expr, I, It);
2931 while Present (It.Nam) loop
2933 -- Note that analysis will have added the interpretation
2934 -- that corresponds to the dereference. We only check the
2935 -- subprogram itself.
2937 if Is_Overloadable (It.Nam) then
2938 Check_One_Function (It.Nam);
2941 Get_Next_Interp (I, It);
2944 if not Indexing_Found then
2946 ("aspect Indexing requires a function that "
2947 & "applies to type&", Expr, Ent);
2951 end Check_Indexing_Functions;
2953 ------------------------------
2954 -- Check_Iterator_Functions --
2955 ------------------------------
2957 procedure Check_Iterator_Functions is
2958 Default : Entity_Id;
2960 function Valid_Default_Iterator (Subp : Entity_Id) return Boolean;
2961 -- Check one possible interpretation for validity
2963 ----------------------------
2964 -- Valid_Default_Iterator --
2965 ----------------------------
2967 function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is
2971 if not Check_Primitive_Function (Subp) then
2974 Formal := First_Formal (Subp);
2977 -- False if any subsequent formal has no default expression
2979 Formal := Next_Formal (Formal);
2980 while Present (Formal) loop
2981 if No (Expression (Parent (Formal))) then
2985 Next_Formal (Formal);
2988 -- True if all subsequent formals have default expressions
2991 end Valid_Default_Iterator;
2993 -- Start of processing for Check_Iterator_Functions
2998 if not Is_Entity_Name (Expr) then
2999 Error_Msg_N ("aspect Iterator must be a function name", Expr);
3002 if not Is_Overloaded (Expr) then
3003 if not Check_Primitive_Function (Entity (Expr)) then
3005 ("aspect Indexing requires a function that applies to type&",
3006 Entity (Expr), Ent);
3009 if not Valid_Default_Iterator (Entity (Expr)) then
3010 Error_Msg_N ("improper function for default iterator", Expr);
3020 Get_First_Interp (Expr, I, It);
3021 while Present (It.Nam) loop
3022 if not Check_Primitive_Function (It.Nam)
3023 or else not Valid_Default_Iterator (It.Nam)
3027 elsif Present (Default) then
3028 Error_Msg_N ("default iterator must be unique", Expr);
3034 Get_Next_Interp (I, It);
3038 if Present (Default) then
3039 Set_Entity (Expr, Default);
3040 Set_Is_Overloaded (Expr, False);
3043 end Check_Iterator_Functions;
3045 -------------------------------
3046 -- Check_Primitive_Function --
3047 -------------------------------
3049 function Check_Primitive_Function (Subp : Entity_Id) return Boolean is
3053 if Ekind (Subp) /= E_Function then
3057 if No (First_Formal (Subp)) then
3060 Ctrl := Etype (First_Formal (Subp));
3064 or else Ctrl = Class_Wide_Type (Ent)
3066 (Ekind (Ctrl) = E_Anonymous_Access_Type
3068 (Designated_Type (Ctrl) = Ent
3069 or else Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
3078 end Check_Primitive_Function;
3080 ----------------------
3081 -- Duplicate_Clause --
3082 ----------------------
3084 function Duplicate_Clause return Boolean is
3088 -- Nothing to do if this attribute definition clause comes from
3089 -- an aspect specification, since we could not be duplicating an
3090 -- explicit clause, and we dealt with the case of duplicated aspects
3091 -- in Analyze_Aspect_Specifications.
3093 if From_Aspect_Specification (N) then
3097 -- Otherwise current clause may duplicate previous clause, or a
3098 -- previously given pragma or aspect specification for the same
3101 A := Get_Rep_Item (U_Ent, Chars (N), Check_Parents => False);
3104 Error_Msg_Name_1 := Chars (N);
3105 Error_Msg_Sloc := Sloc (A);
3107 Error_Msg_NE ("aspect% for & previously given#", N, U_Ent);
3112 end Duplicate_Clause;
3114 -- Start of processing for Analyze_Attribute_Definition_Clause
3117 -- The following code is a defense against recursion. Not clear that
3118 -- this can happen legitimately, but perhaps some error situations
3119 -- can cause it, and we did see this recursion during testing.
3121 if Analyzed (N) then
3124 Set_Analyzed (N, True);
3127 -- Ignore some selected attributes in CodePeer mode since they are not
3128 -- relevant in this context.
3130 if CodePeer_Mode then
3133 -- Ignore Component_Size in CodePeer mode, to avoid changing the
3134 -- internal representation of types by implicitly packing them.
3136 when Attribute_Component_Size =>
3137 Rewrite (N, Make_Null_Statement (Sloc (N)));
3145 -- Process Ignore_Rep_Clauses option
3147 if Ignore_Rep_Clauses then
3150 -- The following should be ignored. They do not affect legality
3151 -- and may be target dependent. The basic idea of -gnatI is to
3152 -- ignore any rep clauses that may be target dependent but do not
3153 -- affect legality (except possibly to be rejected because they
3154 -- are incompatible with the compilation target).
3156 when Attribute_Alignment |
3157 Attribute_Bit_Order |
3158 Attribute_Component_Size |
3159 Attribute_Machine_Radix |
3160 Attribute_Object_Size |
3162 Attribute_Stream_Size |
3163 Attribute_Value_Size =>
3164 Rewrite (N, Make_Null_Statement (Sloc (N)));
3167 -- Perhaps 'Small should not be ignored by Ignore_Rep_Clauses ???
3169 when Attribute_Small =>
3170 if Ignore_Rep_Clauses then
3171 Rewrite (N, Make_Null_Statement (Sloc (N)));
3175 -- The following should not be ignored, because in the first place
3176 -- they are reasonably portable, and should not cause problems in
3177 -- compiling code from another target, and also they do affect
3178 -- legality, e.g. failing to provide a stream attribute for a
3179 -- type may make a program illegal.
3181 when Attribute_External_Tag |
3185 Attribute_Simple_Storage_Pool |
3186 Attribute_Storage_Pool |
3187 Attribute_Storage_Size |
3191 -- Other cases are errors ("attribute& cannot be set with
3192 -- definition clause"), which will be caught below.
3200 Ent := Entity (Nam);
3202 if Rep_Item_Too_Early (Ent, N) then
3206 -- Rep clause applies to full view of incomplete type or private type if
3207 -- we have one (if not, this is a premature use of the type). However,
3208 -- certain semantic checks need to be done on the specified entity (i.e.
3209 -- the private view), so we save it in Ent.
3211 if Is_Private_Type (Ent)
3212 and then Is_Derived_Type (Ent)
3213 and then not Is_Tagged_Type (Ent)
3214 and then No (Full_View (Ent))
3216 -- If this is a private type whose completion is a derivation from
3217 -- another private type, there is no full view, and the attribute
3218 -- belongs to the type itself, not its underlying parent.
3222 elsif Ekind (Ent) = E_Incomplete_Type then
3224 -- The attribute applies to the full view, set the entity of the
3225 -- attribute definition accordingly.
3227 Ent := Underlying_Type (Ent);
3229 Set_Entity (Nam, Ent);
3232 U_Ent := Underlying_Type (Ent);
3235 -- Avoid cascaded error
3237 if Etype (Nam) = Any_Type then
3240 -- Must be declared in current scope or in case of an aspect
3241 -- specification, must be visible in current scope.
3243 elsif Scope (Ent) /= Current_Scope
3245 not (From_Aspect_Specification (N)
3246 and then Scope_Within_Or_Same (Current_Scope, Scope (Ent)))
3248 Error_Msg_N ("entity must be declared in this scope", Nam);
3251 -- Must not be a source renaming (we do have some cases where the
3252 -- expander generates a renaming, and those cases are OK, in such
3253 -- cases any attribute applies to the renamed object as well).
3255 elsif Is_Object (Ent)
3256 and then Present (Renamed_Object (Ent))
3258 -- Case of renamed object from source, this is an error
3260 if Comes_From_Source (Renamed_Object (Ent)) then
3261 Get_Name_String (Chars (N));
3262 Error_Msg_Strlen := Name_Len;
3263 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
3265 ("~ clause not allowed for a renaming declaration "
3266 & "(RM 13.1(6))", Nam);
3269 -- For the case of a compiler generated renaming, the attribute
3270 -- definition clause applies to the renamed object created by the
3271 -- expander. The easiest general way to handle this is to create a
3272 -- copy of the attribute definition clause for this object.
3276 Make_Attribute_Definition_Clause (Loc,
3278 New_Occurrence_Of (Entity (Renamed_Object (Ent)), Loc),
3280 Expression => Duplicate_Subexpr (Expression (N))));
3283 -- If no underlying entity, use entity itself, applies to some
3284 -- previously detected error cases ???
3286 elsif No (U_Ent) then
3289 -- Cannot specify for a subtype (exception Object/Value_Size)
3291 elsif Is_Type (U_Ent)
3292 and then not Is_First_Subtype (U_Ent)
3293 and then Id /= Attribute_Object_Size
3294 and then Id /= Attribute_Value_Size
3295 and then not From_At_Mod (N)
3297 Error_Msg_N ("cannot specify attribute for subtype", Nam);
3301 Set_Entity (N, U_Ent);
3302 Check_Restriction_No_Use_Of_Attribute (N);
3304 -- Switch on particular attribute
3312 -- Address attribute definition clause
3314 when Attribute_Address => Address : begin
3316 -- A little error check, catch for X'Address use X'Address;
3318 if Nkind (Nam) = N_Identifier
3319 and then Nkind (Expr) = N_Attribute_Reference
3320 and then Attribute_Name (Expr) = Name_Address
3321 and then Nkind (Prefix (Expr)) = N_Identifier
3322 and then Chars (Nam) = Chars (Prefix (Expr))
3325 ("address for & is self-referencing", Prefix (Expr), Ent);
3329 -- Not that special case, carry on with analysis of expression
3331 Analyze_And_Resolve (Expr, RTE (RE_Address));
3333 -- Even when ignoring rep clauses we need to indicate that the
3334 -- entity has an address clause and thus it is legal to declare
3337 if Ignore_Rep_Clauses then
3338 if Ekind_In (U_Ent, E_Variable, E_Constant) then
3339 Record_Rep_Item (U_Ent, N);
3345 if Duplicate_Clause then
3348 -- Case of address clause for subprogram
3350 elsif Is_Subprogram (U_Ent) then
3351 if Has_Homonym (U_Ent) then
3353 ("address clause cannot be given " &
3354 "for overloaded subprogram",
3359 -- For subprograms, all address clauses are permitted, and we
3360 -- mark the subprogram as having a deferred freeze so that Gigi
3361 -- will not elaborate it too soon.
3363 -- Above needs more comments, what is too soon about???
3365 Set_Has_Delayed_Freeze (U_Ent);
3367 -- Case of address clause for entry
3369 elsif Ekind (U_Ent) = E_Entry then
3370 if Nkind (Parent (N)) = N_Task_Body then
3372 ("entry address must be specified in task spec", Nam);
3376 -- For entries, we require a constant address
3378 Check_Constant_Address_Clause (Expr, U_Ent);
3380 -- Special checks for task types
3382 if Is_Task_Type (Scope (U_Ent))
3383 and then Comes_From_Source (Scope (U_Ent))
3386 ("??entry address declared for entry in task type", N);
3388 ("\??only one task can be declared of this type", N);
3391 -- Entry address clauses are obsolescent
3393 Check_Restriction (No_Obsolescent_Features, N);
3395 if Warn_On_Obsolescent_Feature then
3397 ("?j?attaching interrupt to task entry is an " &
3398 "obsolescent feature (RM J.7.1)", N);
3400 ("\?j?use interrupt procedure instead", N);
3403 -- Case of an address clause for a controlled object which we
3404 -- consider to be erroneous.
3406 elsif Is_Controlled (Etype (U_Ent))
3407 or else Has_Controlled_Component (Etype (U_Ent))
3410 ("??controlled object& must not be overlaid", Nam, U_Ent);
3412 ("\??Program_Error will be raised at run time", Nam);
3413 Insert_Action (Declaration_Node (U_Ent),
3414 Make_Raise_Program_Error (Loc,
3415 Reason => PE_Overlaid_Controlled_Object));
3418 -- Case of address clause for a (non-controlled) object
3421 Ekind (U_Ent) = E_Variable
3423 Ekind (U_Ent) = E_Constant
3426 Expr : constant Node_Id := Expression (N);
3431 -- Exported variables cannot have an address clause, because
3432 -- this cancels the effect of the pragma Export.
3434 if Is_Exported (U_Ent) then
3436 ("cannot export object with address clause", Nam);
3440 Find_Overlaid_Entity (N, O_Ent, Off);
3442 -- Overlaying controlled objects is erroneous
3445 and then (Has_Controlled_Component (Etype (O_Ent))
3446 or else Is_Controlled (Etype (O_Ent)))
3449 ("??cannot overlay with controlled object", Expr);
3451 ("\??Program_Error will be raised at run time", Expr);
3452 Insert_Action (Declaration_Node (U_Ent),
3453 Make_Raise_Program_Error (Loc,
3454 Reason => PE_Overlaid_Controlled_Object));
3457 elsif Present (O_Ent)
3458 and then Ekind (U_Ent) = E_Constant
3459 and then not Is_Constant_Object (O_Ent)
3461 Error_Msg_N ("??constant overlays a variable", Expr);
3463 -- Imported variables can have an address clause, but then
3464 -- the import is pretty meaningless except to suppress
3465 -- initializations, so we do not need such variables to
3466 -- be statically allocated (and in fact it causes trouble
3467 -- if the address clause is a local value).
3469 elsif Is_Imported (U_Ent) then
3470 Set_Is_Statically_Allocated (U_Ent, False);
3473 -- We mark a possible modification of a variable with an
3474 -- address clause, since it is likely aliasing is occurring.
3476 Note_Possible_Modification (Nam, Sure => False);
3478 -- Here we are checking for explicit overlap of one variable
3479 -- by another, and if we find this then mark the overlapped
3480 -- variable as also being volatile to prevent unwanted
3481 -- optimizations. This is a significant pessimization so
3482 -- avoid it when there is an offset, i.e. when the object
3483 -- is composite; they cannot be optimized easily anyway.
3486 and then Is_Object (O_Ent)
3489 -- The following test is an expedient solution to what
3490 -- is really a problem in CodePeer. Suppressing the
3491 -- Set_Treat_As_Volatile call here prevents later
3492 -- generation (in some cases) of trees that CodePeer
3493 -- should, but currently does not, handle correctly.
3494 -- This test should probably be removed when CodePeer
3495 -- is improved, just because we want the tree CodePeer
3496 -- analyzes to match the tree for which we generate code
3497 -- as closely as is practical. ???
3499 and then not CodePeer_Mode
3501 -- ??? O_Ent might not be in current unit
3503 Set_Treat_As_Volatile (O_Ent);
3506 -- Legality checks on the address clause for initialized
3507 -- objects is deferred until the freeze point, because
3508 -- a subsequent pragma might indicate that the object
3509 -- is imported and thus not initialized. Also, the address
3510 -- clause might involve entities that have yet to be
3513 Set_Has_Delayed_Freeze (U_Ent);
3515 -- If an initialization call has been generated for this
3516 -- object, it needs to be deferred to after the freeze node
3517 -- we have just now added, otherwise GIGI will see a
3518 -- reference to the variable (as actual to the IP call)
3519 -- before its definition.
3522 Init_Call : constant Node_Id :=
3523 Remove_Init_Call (U_Ent, N);
3526 if Present (Init_Call) then
3528 -- If the init call is an expression with actions with
3529 -- null expression, just extract the actions.
3531 if Nkind (Init_Call) = N_Expression_With_Actions
3533 Nkind (Expression (Init_Call)) = N_Null_Statement
3535 Append_Freeze_Actions (U_Ent, Actions (Init_Call));
3537 -- General case: move Init_Call to freeze actions
3540 Append_Freeze_Action (U_Ent, Init_Call);
3545 if Is_Exported (U_Ent) then
3547 ("& cannot be exported if an address clause is given",
3550 ("\define and export a variable "
3551 & "that holds its address instead", Nam);
3554 -- Entity has delayed freeze, so we will generate an
3555 -- alignment check at the freeze point unless suppressed.
3557 if not Range_Checks_Suppressed (U_Ent)
3558 and then not Alignment_Checks_Suppressed (U_Ent)
3560 Set_Check_Address_Alignment (N);
3563 -- Kill the size check code, since we are not allocating
3564 -- the variable, it is somewhere else.
3566 Kill_Size_Check_Code (U_Ent);
3568 -- If the address clause is of the form:
3570 -- for Y'Address use X'Address
3574 -- Const : constant Address := X'Address;
3576 -- for Y'Address use Const;
3578 -- then we make an entry in the table for checking the size
3579 -- and alignment of the overlaying variable. We defer this
3580 -- check till after code generation to take full advantage
3581 -- of the annotation done by the back end.
3583 -- If the entity has a generic type, the check will be
3584 -- performed in the instance if the actual type justifies
3585 -- it, and we do not insert the clause in the table to
3586 -- prevent spurious warnings.
3588 -- Note: we used to test Comes_From_Source and only give
3589 -- this warning for source entities, but we have removed
3590 -- this test. It really seems bogus to generate overlays
3591 -- that would trigger this warning in generated code.
3592 -- Furthermore, by removing the test, we handle the
3593 -- aspect case properly.
3595 if Address_Clause_Overlay_Warnings
3596 and then Present (O_Ent)
3597 and then Is_Object (O_Ent)
3599 if not Is_Generic_Type (Etype (U_Ent)) then
3600 Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off));
3603 -- If variable overlays a constant view, and we are
3604 -- warning on overlays, then mark the variable as
3605 -- overlaying a constant (we will give warnings later
3606 -- if this variable is assigned).
3608 if Is_Constant_Object (O_Ent)
3609 and then Ekind (U_Ent) = E_Variable
3611 Set_Overlays_Constant (U_Ent);
3616 -- Not a valid entity for an address clause
3619 Error_Msg_N ("address cannot be given for &", Nam);
3627 -- Alignment attribute definition clause
3629 when Attribute_Alignment => Alignment : declare
3630 Align : constant Uint := Get_Alignment_Value (Expr);
3631 Max_Align : constant Uint := UI_From_Int (Maximum_Alignment);
3636 if not Is_Type (U_Ent)
3637 and then Ekind (U_Ent) /= E_Variable
3638 and then Ekind (U_Ent) /= E_Constant
3640 Error_Msg_N ("alignment cannot be given for &", Nam);
3642 elsif Duplicate_Clause then
3645 elsif Align /= No_Uint then
3646 Set_Has_Alignment_Clause (U_Ent);
3648 -- Tagged type case, check for attempt to set alignment to a
3649 -- value greater than Max_Align, and reset if so.
3651 if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
3653 ("alignment for & set to Maximum_Aligment??", Nam);
3654 Set_Alignment (U_Ent, Max_Align);
3659 Set_Alignment (U_Ent, Align);
3662 -- For an array type, U_Ent is the first subtype. In that case,
3663 -- also set the alignment of the anonymous base type so that
3664 -- other subtypes (such as the itypes for aggregates of the
3665 -- type) also receive the expected alignment.
3667 if Is_Array_Type (U_Ent) then
3668 Set_Alignment (Base_Type (U_Ent), Align);
3677 -- Bit_Order attribute definition clause
3679 when Attribute_Bit_Order => Bit_Order : declare
3681 if not Is_Record_Type (U_Ent) then
3683 ("Bit_Order can only be defined for record type", Nam);
3685 elsif Duplicate_Clause then
3689 Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
3691 if Etype (Expr) = Any_Type then
3694 elsif not Is_Static_Expression (Expr) then
3695 Flag_Non_Static_Expr
3696 ("Bit_Order requires static expression!", Expr);
3699 if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
3700 Set_Reverse_Bit_Order (U_Ent, True);
3706 --------------------
3707 -- Component_Size --
3708 --------------------
3710 -- Component_Size attribute definition clause
3712 when Attribute_Component_Size => Component_Size_Case : declare
3713 Csize : constant Uint := Static_Integer (Expr);
3717 New_Ctyp : Entity_Id;
3721 if not Is_Array_Type (U_Ent) then
3722 Error_Msg_N ("component size requires array type", Nam);
3726 Btype := Base_Type (U_Ent);
3727 Ctyp := Component_Type (Btype);
3729 if Duplicate_Clause then
3732 elsif Rep_Item_Too_Early (Btype, N) then
3735 elsif Csize /= No_Uint then
3736 Check_Size (Expr, Ctyp, Csize, Biased);
3738 -- For the biased case, build a declaration for a subtype that
3739 -- will be used to represent the biased subtype that reflects
3740 -- the biased representation of components. We need the subtype
3741 -- to get proper conversions on referencing elements of the
3742 -- array. Note: component size clauses are ignored in VM mode.
3744 if VM_Target = No_VM then
3747 Make_Defining_Identifier (Loc,
3749 New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
3752 Make_Subtype_Declaration (Loc,
3753 Defining_Identifier => New_Ctyp,
3754 Subtype_Indication =>
3755 New_Occurrence_Of (Component_Type (Btype), Loc));
3757 Set_Parent (Decl, N);
3758 Analyze (Decl, Suppress => All_Checks);
3760 Set_Has_Delayed_Freeze (New_Ctyp, False);
3761 Set_Esize (New_Ctyp, Csize);
3762 Set_RM_Size (New_Ctyp, Csize);
3763 Init_Alignment (New_Ctyp);
3764 Set_Is_Itype (New_Ctyp, True);
3765 Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
3767 Set_Component_Type (Btype, New_Ctyp);
3768 Set_Biased (New_Ctyp, N, "component size clause");
3771 Set_Component_Size (Btype, Csize);
3773 -- For VM case, we ignore component size clauses
3776 -- Give a warning unless we are in GNAT mode, in which case
3777 -- the warning is suppressed since it is not useful.
3779 if not GNAT_Mode then
3781 ("component size ignored in this configuration??", N);
3785 -- Deal with warning on overridden size
3787 if Warn_On_Overridden_Size
3788 and then Has_Size_Clause (Ctyp)
3789 and then RM_Size (Ctyp) /= Csize
3792 ("component size overrides size clause for&?S?", N, Ctyp);
3795 Set_Has_Component_Size_Clause (Btype, True);
3796 Set_Has_Non_Standard_Rep (Btype, True);
3798 end Component_Size_Case;
3800 -----------------------
3801 -- Constant_Indexing --
3802 -----------------------
3804 when Attribute_Constant_Indexing =>
3805 Check_Indexing_Functions;
3811 when Attribute_CPU => CPU :
3813 -- CPU attribute definition clause not allowed except from aspect
3816 if From_Aspect_Specification (N) then
3817 if not Is_Task_Type (U_Ent) then
3818 Error_Msg_N ("CPU can only be defined for task", Nam);
3820 elsif Duplicate_Clause then
3824 -- The expression must be analyzed in the special manner
3825 -- described in "Handling of Default and Per-Object
3826 -- Expressions" in sem.ads.
3828 -- The visibility to the discriminants must be restored
3830 Push_Scope_And_Install_Discriminants (U_Ent);
3831 Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range));
3832 Uninstall_Discriminants_And_Pop_Scope (U_Ent);
3834 if not Is_Static_Expression (Expr) then
3835 Check_Restriction (Static_Priorities, Expr);
3841 ("attribute& cannot be set with definition clause", N);
3845 ----------------------
3846 -- Default_Iterator --
3847 ----------------------
3849 when Attribute_Default_Iterator => Default_Iterator : declare
3853 if not Is_Tagged_Type (U_Ent) then
3855 ("aspect Default_Iterator applies to tagged type", Nam);
3858 Check_Iterator_Functions;
3862 if not Is_Entity_Name (Expr)
3863 or else Ekind (Entity (Expr)) /= E_Function
3865 Error_Msg_N ("aspect Iterator must be a function", Expr);
3867 Func := Entity (Expr);
3870 if No (First_Formal (Func))
3871 or else Etype (First_Formal (Func)) /= U_Ent
3874 ("Default Iterator must be a primitive of&", Func, U_Ent);
3876 end Default_Iterator;
3878 ------------------------
3879 -- Dispatching_Domain --
3880 ------------------------
3882 when Attribute_Dispatching_Domain => Dispatching_Domain :
3884 -- Dispatching_Domain attribute definition clause not allowed
3885 -- except from aspect specification.
3887 if From_Aspect_Specification (N) then
3888 if not Is_Task_Type (U_Ent) then
3889 Error_Msg_N ("Dispatching_Domain can only be defined" &
3893 elsif Duplicate_Clause then
3897 -- The expression must be analyzed in the special manner
3898 -- described in "Handling of Default and Per-Object
3899 -- Expressions" in sem.ads.
3901 -- The visibility to the discriminants must be restored
3903 Push_Scope_And_Install_Discriminants (U_Ent);
3905 Preanalyze_Spec_Expression
3906 (Expr, RTE (RE_Dispatching_Domain));
3908 Uninstall_Discriminants_And_Pop_Scope (U_Ent);
3913 ("attribute& cannot be set with definition clause", N);
3915 end Dispatching_Domain;
3921 when Attribute_External_Tag => External_Tag :
3923 if not Is_Tagged_Type (U_Ent) then
3924 Error_Msg_N ("should be a tagged type", Nam);
3927 if Duplicate_Clause then
3931 Analyze_And_Resolve (Expr, Standard_String);
3933 if not Is_Static_Expression (Expr) then
3934 Flag_Non_Static_Expr
3935 ("static string required for tag name!", Nam);
3938 if VM_Target = No_VM then
3939 Set_Has_External_Tag_Rep_Clause (U_Ent);
3941 Error_Msg_Name_1 := Attr;
3943 ("% attribute unsupported in this configuration", Nam);
3946 if not Is_Library_Level_Entity (U_Ent) then
3948 ("??non-unique external tag supplied for &", N, U_Ent);
3950 ("\??same external tag applies to all "
3951 & "subprogram calls", N);
3953 ("\??corresponding internal tag cannot be obtained", N);
3958 --------------------------
3959 -- Implicit_Dereference --
3960 --------------------------
3962 when Attribute_Implicit_Dereference =>
3964 -- Legality checks already performed at the point of the type
3965 -- declaration, aspect is not delayed.
3973 when Attribute_Input =>
3974 Analyze_Stream_TSS_Definition (TSS_Stream_Input);
3975 Set_Has_Specified_Stream_Input (Ent);
3977 ------------------------
3978 -- Interrupt_Priority --
3979 ------------------------
3981 when Attribute_Interrupt_Priority => Interrupt_Priority :
3983 -- Interrupt_Priority attribute definition clause not allowed
3984 -- except from aspect specification.
3986 if From_Aspect_Specification (N) then
3987 if not (Is_Protected_Type (U_Ent)
3988 or else Is_Task_Type (U_Ent))
3991 ("Interrupt_Priority can only be defined for task" &
3992 "and protected object",
3995 elsif Duplicate_Clause then
3999 -- The expression must be analyzed in the special manner
4000 -- described in "Handling of Default and Per-Object
4001 -- Expressions" in sem.ads.
4003 -- The visibility to the discriminants must be restored
4005 Push_Scope_And_Install_Discriminants (U_Ent);
4007 Preanalyze_Spec_Expression
4008 (Expr, RTE (RE_Interrupt_Priority));
4010 Uninstall_Discriminants_And_Pop_Scope (U_Ent);
4015 ("attribute& cannot be set with definition clause", N);
4017 end Interrupt_Priority;
4019 ----------------------
4020 -- Iterator_Element --
4021 ----------------------
4023 when Attribute_Iterator_Element =>
4026 if not Is_Entity_Name (Expr)
4027 or else not Is_Type (Entity (Expr))
4029 Error_Msg_N ("aspect Iterator_Element must be a type", Expr);
4036 -- Machine radix attribute definition clause
4038 when Attribute_Machine_Radix => Machine_Radix : declare
4039 Radix : constant Uint := Static_Integer (Expr);
4042 if not Is_Decimal_Fixed_Point_Type (U_Ent) then
4043 Error_Msg_N ("decimal fixed-point type expected for &", Nam);
4045 elsif Duplicate_Clause then
4048 elsif Radix /= No_Uint then
4049 Set_Has_Machine_Radix_Clause (U_Ent);
4050 Set_Has_Non_Standard_Rep (Base_Type (U_Ent));
4054 elsif Radix = 10 then
4055 Set_Machine_Radix_10 (U_Ent);
4057 Error_Msg_N ("machine radix value must be 2 or 10", Expr);
4066 -- Object_Size attribute definition clause
4068 when Attribute_Object_Size => Object_Size : declare
4069 Size : constant Uint := Static_Integer (Expr);
4072 pragma Warnings (Off, Biased);
4075 if not Is_Type (U_Ent) then
4076 Error_Msg_N ("Object_Size cannot be given for &", Nam);
4078 elsif Duplicate_Clause then
4082 Check_Size (Expr, U_Ent, Size, Biased);
4090 UI_Mod (Size, 64) /= 0
4093 ("Object_Size must be 8, 16, 32, or multiple of 64",
4097 Set_Esize (U_Ent, Size);
4098 Set_Has_Object_Size_Clause (U_Ent);
4099 Alignment_Check_For_Size_Change (U_Ent, Size);
4107 when Attribute_Output =>
4108 Analyze_Stream_TSS_Definition (TSS_Stream_Output);
4109 Set_Has_Specified_Stream_Output (Ent);
4115 when Attribute_Priority => Priority :
4117 -- Priority attribute definition clause not allowed except from
4118 -- aspect specification.
4120 if From_Aspect_Specification (N) then
4121 if not (Is_Protected_Type (U_Ent)
4122 or else Is_Task_Type (U_Ent)
4123 or else Ekind (U_Ent) = E_Procedure)
4126 ("Priority can only be defined for task and protected " &
4130 elsif Duplicate_Clause then
4134 -- The expression must be analyzed in the special manner
4135 -- described in "Handling of Default and Per-Object
4136 -- Expressions" in sem.ads.
4138 -- The visibility to the discriminants must be restored
4140 Push_Scope_And_Install_Discriminants (U_Ent);
4141 Preanalyze_Spec_Expression (Expr, Standard_Integer);
4142 Uninstall_Discriminants_And_Pop_Scope (U_Ent);
4144 if not Is_Static_Expression (Expr) then
4145 Check_Restriction (Static_Priorities, Expr);
4151 ("attribute& cannot be set with definition clause", N);
4159 when Attribute_Read =>
4160 Analyze_Stream_TSS_Definition (TSS_Stream_Read);
4161 Set_Has_Specified_Stream_Read (Ent);
4163 --------------------------
4164 -- Scalar_Storage_Order --
4165 --------------------------
4167 -- Scalar_Storage_Order attribute definition clause
4169 when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare
4171 if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then
4173 ("Scalar_Storage_Order can only be defined for "
4174 & "record or array type", Nam);
4176 elsif Duplicate_Clause then
4180 Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
4182 if Etype (Expr) = Any_Type then
4185 elsif not Is_Static_Expression (Expr) then
4186 Flag_Non_Static_Expr
4187 ("Scalar_Storage_Order requires static expression!", Expr);
4189 elsif (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
4191 -- Here for the case of a non-default (i.e. non-confirming)
4192 -- Scalar_Storage_Order attribute definition.
4194 if Support_Nondefault_SSO_On_Target then
4195 Set_Reverse_Storage_Order (Base_Type (U_Ent), True);
4198 ("non-default Scalar_Storage_Order "
4199 & "not supported on target", Expr);
4203 end Scalar_Storage_Order;
4209 -- Size attribute definition clause
4211 when Attribute_Size => Size : declare
4212 Size : constant Uint := Static_Integer (Expr);
4219 if Duplicate_Clause then
4222 elsif not Is_Type (U_Ent)
4223 and then Ekind (U_Ent) /= E_Variable
4224 and then Ekind (U_Ent) /= E_Constant
4226 Error_Msg_N ("size cannot be given for &", Nam);
4228 elsif Is_Array_Type (U_Ent)
4229 and then not Is_Constrained (U_Ent)
4232 ("size cannot be given for unconstrained array", Nam);
4234 elsif Size /= No_Uint then
4235 if VM_Target /= No_VM and then not GNAT_Mode then
4237 -- Size clause is not handled properly on VM targets.
4238 -- Display a warning unless we are in GNAT mode, in which
4239 -- case this is useless.
4242 ("size clauses are ignored in this configuration??", N);
4245 if Is_Type (U_Ent) then
4248 Etyp := Etype (U_Ent);
4251 -- Check size, note that Gigi is in charge of checking that the
4252 -- size of an array or record type is OK. Also we do not check
4253 -- the size in the ordinary fixed-point case, since it is too
4254 -- early to do so (there may be subsequent small clause that
4255 -- affects the size). We can check the size if a small clause
4256 -- has already been given.
4258 if not Is_Ordinary_Fixed_Point_Type (U_Ent)
4259 or else Has_Small_Clause (U_Ent)
4261 Check_Size (Expr, Etyp, Size, Biased);
4262 Set_Biased (U_Ent, N, "size clause", Biased);
4265 -- For types set RM_Size and Esize if possible
4267 if Is_Type (U_Ent) then
4268 Set_RM_Size (U_Ent, Size);
4270 -- For elementary types, increase Object_Size to power of 2,
4271 -- but not less than a storage unit in any case (normally
4272 -- this means it will be byte addressable).
4274 -- For all other types, nothing else to do, we leave Esize
4275 -- (object size) unset, the back end will set it from the
4276 -- size and alignment in an appropriate manner.
4278 -- In both cases, we check whether the alignment must be
4279 -- reset in the wake of the size change.
4281 if Is_Elementary_Type (U_Ent) then
4282 if Size <= System_Storage_Unit then
4283 Init_Esize (U_Ent, System_Storage_Unit);
4284 elsif Size <= 16 then
4285 Init_Esize (U_Ent, 16);
4286 elsif Size <= 32 then
4287 Init_Esize (U_Ent, 32);
4289 Set_Esize (U_Ent, (Size + 63) / 64 * 64);
4292 Alignment_Check_For_Size_Change (U_Ent, Esize (U_Ent));
4294 Alignment_Check_For_Size_Change (U_Ent, Size);
4297 -- For objects, set Esize only
4300 if Is_Elementary_Type (Etyp) then
4301 if Size /= System_Storage_Unit
4303 Size /= System_Storage_Unit * 2
4305 Size /= System_Storage_Unit * 4
4307 Size /= System_Storage_Unit * 8
4309 Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
4310 Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
4312 ("size for primitive object must be a power of 2"
4313 & " in the range ^-^", N);
4317 Set_Esize (U_Ent, Size);
4320 Set_Has_Size_Clause (U_Ent);
4328 -- Small attribute definition clause
4330 when Attribute_Small => Small : declare
4331 Implicit_Base : constant Entity_Id := Base_Type (U_Ent);
4335 Analyze_And_Resolve (Expr, Any_Real);
4337 if Etype (Expr) = Any_Type then
4340 elsif not Is_Static_Expression (Expr) then
4341 Flag_Non_Static_Expr
4342 ("small requires static expression!", Expr);
4346 Small := Expr_Value_R (Expr);
4348 if Small <= Ureal_0 then
4349 Error_Msg_N ("small value must be greater than zero", Expr);
4355 if not Is_Ordinary_Fixed_Point_Type (U_Ent) then
4357 ("small requires an ordinary fixed point type", Nam);
4359 elsif Has_Small_Clause (U_Ent) then
4360 Error_Msg_N ("small already given for &", Nam);
4362 elsif Small > Delta_Value (U_Ent) then
4364 ("small value must not be greater than delta value", Nam);
4367 Set_Small_Value (U_Ent, Small);
4368 Set_Small_Value (Implicit_Base, Small);
4369 Set_Has_Small_Clause (U_Ent);
4370 Set_Has_Small_Clause (Implicit_Base);
4371 Set_Has_Non_Standard_Rep (Implicit_Base);
4379 -- Storage_Pool attribute definition clause
4381 when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare
4386 if Ekind (U_Ent) = E_Access_Subprogram_Type then
4388 ("storage pool cannot be given for access-to-subprogram type",
4393 Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type)
4396 ("storage pool can only be given for access types", Nam);
4399 elsif Is_Derived_Type (U_Ent) then
4401 ("storage pool cannot be given for a derived access type",
4404 elsif Duplicate_Clause then
4407 elsif Present (Associated_Storage_Pool (U_Ent)) then
4408 Error_Msg_N ("storage pool already given for &", Nam);
4412 if Id = Attribute_Storage_Pool then
4414 (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
4416 -- In the Simple_Storage_Pool case, we allow a variable of any
4417 -- simple storage pool type, so we Resolve without imposing an
4421 Analyze_And_Resolve (Expr);
4423 if not Present (Get_Rep_Pragma
4424 (Etype (Expr), Name_Simple_Storage_Pool_Type))
4427 ("expression must be of a simple storage pool type", Expr);
4431 if not Denotes_Variable (Expr) then
4432 Error_Msg_N ("storage pool must be a variable", Expr);
4436 if Nkind (Expr) = N_Type_Conversion then
4437 T := Etype (Expression (Expr));
4442 -- The Stack_Bounded_Pool is used internally for implementing
4443 -- access types with a Storage_Size. Since it only work properly
4444 -- when used on one specific type, we need to check that it is not
4445 -- hijacked improperly:
4447 -- type T is access Integer;
4448 -- for T'Storage_Size use n;
4449 -- type Q is access Float;
4450 -- for Q'Storage_Size use T'Storage_Size; -- incorrect
4452 if RTE_Available (RE_Stack_Bounded_Pool)
4453 and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool)
4455 Error_Msg_N ("non-shareable internal Pool", Expr);
4459 -- If the argument is a name that is not an entity name, then
4460 -- we construct a renaming operation to define an entity of
4461 -- type storage pool.
4463 if not Is_Entity_Name (Expr)
4464 and then Is_Object_Reference (Expr)
4466 Pool := Make_Temporary (Loc, 'P', Expr);
4469 Rnode : constant Node_Id :=
4470 Make_Object_Renaming_Declaration (Loc,
4471 Defining_Identifier => Pool,
4473 New_Occurrence_Of (Etype (Expr), Loc),
4477 -- If the attribute definition clause comes from an aspect
4478 -- clause, then insert the renaming before the associated
4479 -- entity's declaration, since the attribute clause has
4480 -- not yet been appended to the declaration list.
4482 if From_Aspect_Specification (N) then
4483 Insert_Before (Parent (Entity (N)), Rnode);
4485 Insert_Before (N, Rnode);
4489 Set_Associated_Storage_Pool (U_Ent, Pool);
4492 elsif Is_Entity_Name (Expr) then
4493 Pool := Entity (Expr);
4495 -- If pool is a renamed object, get original one. This can
4496 -- happen with an explicit renaming, and within instances.
4498 while Present (Renamed_Object (Pool))
4499 and then Is_Entity_Name (Renamed_Object (Pool))
4501 Pool := Entity (Renamed_Object (Pool));
4504 if Present (Renamed_Object (Pool))
4505 and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion
4506 and then Is_Entity_Name (Expression (Renamed_Object (Pool)))
4508 Pool := Entity (Expression (Renamed_Object (Pool)));
4511 Set_Associated_Storage_Pool (U_Ent, Pool);
4513 elsif Nkind (Expr) = N_Type_Conversion
4514 and then Is_Entity_Name (Expression (Expr))
4515 and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
4517 Pool := Entity (Expression (Expr));
4518 Set_Associated_Storage_Pool (U_Ent, Pool);
4521 Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
4530 -- Storage_Size attribute definition clause
4532 when Attribute_Storage_Size => Storage_Size : declare
4533 Btype : constant Entity_Id := Base_Type (U_Ent);
4536 if Is_Task_Type (U_Ent) then
4538 -- Check obsolescent (but never obsolescent if from aspect!)
4540 if not From_Aspect_Specification (N) then
4541 Check_Restriction (No_Obsolescent_Features, N);
4543 if Warn_On_Obsolescent_Feature then
4545 ("?j?storage size clause for task is an " &
4546 "obsolescent feature (RM J.9)", N);
4547 Error_Msg_N ("\?j?use Storage_Size pragma instead", N);
4554 if not Is_Access_Type (U_Ent)
4555 and then Ekind (U_Ent) /= E_Task_Type
4557 Error_Msg_N ("storage size cannot be given for &", Nam);
4559 elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
4561 ("storage size cannot be given for a derived access type",
4564 elsif Duplicate_Clause then
4568 Analyze_And_Resolve (Expr, Any_Integer);
4570 if Is_Access_Type (U_Ent) then
4571 if Present (Associated_Storage_Pool (U_Ent)) then
4572 Error_Msg_N ("storage pool already given for &", Nam);
4576 if Is_OK_Static_Expression (Expr)
4577 and then Expr_Value (Expr) = 0
4579 Set_No_Pool_Assigned (Btype);
4583 Set_Has_Storage_Size_Clause (Btype);
4591 when Attribute_Stream_Size => Stream_Size : declare
4592 Size : constant Uint := Static_Integer (Expr);
4595 if Ada_Version <= Ada_95 then
4596 Check_Restriction (No_Implementation_Attributes, N);
4599 if Duplicate_Clause then
4602 elsif Is_Elementary_Type (U_Ent) then
4603 if Size /= System_Storage_Unit
4605 Size /= System_Storage_Unit * 2
4607 Size /= System_Storage_Unit * 4
4609 Size /= System_Storage_Unit * 8
4611 Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
4613 ("stream size for elementary type must be a"
4614 & " power of 2 and at least ^", N);
4616 elsif RM_Size (U_Ent) > Size then
4617 Error_Msg_Uint_1 := RM_Size (U_Ent);
4619 ("stream size for elementary type must be a"
4620 & " power of 2 and at least ^", N);
4623 Set_Has_Stream_Size_Clause (U_Ent);
4626 Error_Msg_N ("Stream_Size cannot be given for &", Nam);
4634 -- Value_Size attribute definition clause
4636 when Attribute_Value_Size => Value_Size : declare
4637 Size : constant Uint := Static_Integer (Expr);
4641 if not Is_Type (U_Ent) then
4642 Error_Msg_N ("Value_Size cannot be given for &", Nam);
4644 elsif Duplicate_Clause then
4647 elsif Is_Array_Type (U_Ent)
4648 and then not Is_Constrained (U_Ent)
4651 ("Value_Size cannot be given for unconstrained array", Nam);
4654 if Is_Elementary_Type (U_Ent) then
4655 Check_Size (Expr, U_Ent, Size, Biased);
4656 Set_Biased (U_Ent, N, "value size clause", Biased);
4659 Set_RM_Size (U_Ent, Size);
4663 -----------------------
4664 -- Variable_Indexing --
4665 -----------------------
4667 when Attribute_Variable_Indexing =>
4668 Check_Indexing_Functions;
4674 when Attribute_Write =>
4675 Analyze_Stream_TSS_Definition (TSS_Stream_Write);
4676 Set_Has_Specified_Stream_Write (Ent);
4678 -- All other attributes cannot be set
4682 ("attribute& cannot be set with definition clause", N);
4685 -- The test for the type being frozen must be performed after any
4686 -- expression the clause has been analyzed since the expression itself
4687 -- might cause freezing that makes the clause illegal.
4689 if Rep_Item_Too_Late (U_Ent, N, FOnly) then
4692 end Analyze_Attribute_Definition_Clause;
4694 ----------------------------
4695 -- Analyze_Code_Statement --
4696 ----------------------------
4698 procedure Analyze_Code_Statement (N : Node_Id) is
4699 HSS : constant Node_Id := Parent (N);
4700 SBody : constant Node_Id := Parent (HSS);
4701 Subp : constant Entity_Id := Current_Scope;
4708 -- Analyze and check we get right type, note that this implements the
4709 -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that
4710 -- is the only way that Asm_Insn could possibly be visible.
4712 Analyze_And_Resolve (Expression (N));
4714 if Etype (Expression (N)) = Any_Type then
4716 elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
4717 Error_Msg_N ("incorrect type for code statement", N);
4721 Check_Code_Statement (N);
4723 -- Make sure we appear in the handled statement sequence of a
4724 -- subprogram (RM 13.8(3)).
4726 if Nkind (HSS) /= N_Handled_Sequence_Of_Statements
4727 or else Nkind (SBody) /= N_Subprogram_Body
4730 ("code statement can only appear in body of subprogram", N);
4734 -- Do remaining checks (RM 13.8(3)) if not already done
4736 if not Is_Machine_Code_Subprogram (Subp) then
4737 Set_Is_Machine_Code_Subprogram (Subp);
4739 -- No exception handlers allowed
4741 if Present (Exception_Handlers (HSS)) then
4743 ("exception handlers not permitted in machine code subprogram",
4744 First (Exception_Handlers (HSS)));
4747 -- No declarations other than use clauses and pragmas (we allow
4748 -- certain internally generated declarations as well).
4750 Decl := First (Declarations (SBody));
4751 while Present (Decl) loop
4752 DeclO := Original_Node (Decl);
4753 if Comes_From_Source (DeclO)
4754 and not Nkind_In (DeclO, N_Pragma,
4755 N_Use_Package_Clause,
4757 N_Implicit_Label_Declaration)
4760 ("this declaration not allowed in machine code subprogram",
4767 -- No statements other than code statements, pragmas, and labels.
4768 -- Again we allow certain internally generated statements.
4770 -- In Ada 2012, qualified expressions are names, and the code
4771 -- statement is initially parsed as a procedure call.
4773 Stmt := First (Statements (HSS));
4774 while Present (Stmt) loop
4775 StmtO := Original_Node (Stmt);
4777 -- A procedure call transformed into a code statement is OK.
4779 if Ada_Version >= Ada_2012
4780 and then Nkind (StmtO) = N_Procedure_Call_Statement
4781 and then Nkind (Name (StmtO)) = N_Qualified_Expression
4785 elsif Comes_From_Source (StmtO)
4786 and then not Nkind_In (StmtO, N_Pragma,
4791 ("this statement is not allowed in machine code subprogram",
4798 end Analyze_Code_Statement;
4800 -----------------------------------------------
4801 -- Analyze_Enumeration_Representation_Clause --
4802 -----------------------------------------------
4804 procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
4805 Ident : constant Node_Id := Identifier (N);
4806 Aggr : constant Node_Id := Array_Aggregate (N);
4807 Enumtype : Entity_Id;
4814 Err : Boolean := False;
4815 -- Set True to avoid cascade errors and crashes on incorrect source code
4817 Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
4818 Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
4819 -- Allowed range of universal integer (= allowed range of enum lit vals)
4823 -- Minimum and maximum values of entries
4826 -- Pointer to node for literal providing max value
4829 if Ignore_Rep_Clauses then
4833 -- Ignore enumeration rep clauses by default in CodePeer mode,
4834 -- unless -gnatd.I is specified, as a work around for potential false
4835 -- positive messages.
4837 if CodePeer_Mode and not Debug_Flag_Dot_II then
4841 -- First some basic error checks
4844 Enumtype := Entity (Ident);
4846 if Enumtype = Any_Type
4847 or else Rep_Item_Too_Early (Enumtype, N)
4851 Enumtype := Underlying_Type (Enumtype);
4854 if not Is_Enumeration_Type (Enumtype) then
4856 ("enumeration type required, found}",
4857 Ident, First_Subtype (Enumtype));
4861 -- Ignore rep clause on generic actual type. This will already have
4862 -- been flagged on the template as an error, and this is the safest
4863 -- way to ensure we don't get a junk cascaded message in the instance.
4865 if Is_Generic_Actual_Type (Enumtype) then
4868 -- Type must be in current scope
4870 elsif Scope (Enumtype) /= Current_Scope then
4871 Error_Msg_N ("type must be declared in this scope", Ident);
4874 -- Type must be a first subtype
4876 elsif not Is_First_Subtype (Enumtype) then
4877 Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
4880 -- Ignore duplicate rep clause
4882 elsif Has_Enumeration_Rep_Clause (Enumtype) then
4883 Error_Msg_N ("duplicate enumeration rep clause ignored", N);
4886 -- Don't allow rep clause for standard [wide_[wide_]]character
4888 elsif Is_Standard_Character_Type (Enumtype) then
4889 Error_Msg_N ("enumeration rep clause not allowed for this type", N);
4892 -- Check that the expression is a proper aggregate (no parentheses)
4894 elsif Paren_Count (Aggr) /= 0 then
4896 ("extra parentheses surrounding aggregate not allowed",
4900 -- All tests passed, so set rep clause in place
4903 Set_Has_Enumeration_Rep_Clause (Enumtype);
4904 Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype));
4907 -- Now we process the aggregate. Note that we don't use the normal
4908 -- aggregate code for this purpose, because we don't want any of the
4909 -- normal expansion activities, and a number of special semantic
4910 -- rules apply (including the component type being any integer type)
4912 Elit := First_Literal (Enumtype);
4914 -- First the positional entries if any
4916 if Present (Expressions (Aggr)) then
4917 Expr := First (Expressions (Aggr));
4918 while Present (Expr) loop
4920 Error_Msg_N ("too many entries in aggregate", Expr);
4924 Val := Static_Integer (Expr);
4926 -- Err signals that we found some incorrect entries processing
4927 -- the list. The final checks for completeness and ordering are
4928 -- skipped in this case.
4930 if Val = No_Uint then
4932 elsif Val < Lo or else Hi < Val then
4933 Error_Msg_N ("value outside permitted range", Expr);
4937 Set_Enumeration_Rep (Elit, Val);
4938 Set_Enumeration_Rep_Expr (Elit, Expr);
4944 -- Now process the named entries if present
4946 if Present (Component_Associations (Aggr)) then
4947 Assoc := First (Component_Associations (Aggr));
4948 while Present (Assoc) loop
4949 Choice := First (Choices (Assoc));
4951 if Present (Next (Choice)) then
4953 ("multiple choice not allowed here", Next (Choice));
4957 if Nkind (Choice) = N_Others_Choice then
4958 Error_Msg_N ("others choice not allowed here", Choice);
4961 elsif Nkind (Choice) = N_Range then
4963 -- ??? should allow zero/one element range here
4965 Error_Msg_N ("range not allowed here", Choice);
4969 Analyze_And_Resolve (Choice, Enumtype);
4971 if Error_Posted (Choice) then
4976 if Is_Entity_Name (Choice)
4977 and then Is_Type (Entity (Choice))
4979 Error_Msg_N ("subtype name not allowed here", Choice);
4982 -- ??? should allow static subtype with zero/one entry
4984 elsif Etype (Choice) = Base_Type (Enumtype) then
4985 if not Is_Static_Expression (Choice) then
4986 Flag_Non_Static_Expr
4987 ("non-static expression used for choice!", Choice);
4991 Elit := Expr_Value_E (Choice);
4993 if Present (Enumeration_Rep_Expr (Elit)) then
4995 Sloc (Enumeration_Rep_Expr (Elit));
4997 ("representation for& previously given#",
5002 Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
5004 Expr := Expression (Assoc);
5005 Val := Static_Integer (Expr);
5007 if Val = No_Uint then
5010 elsif Val < Lo or else Hi < Val then
5011 Error_Msg_N ("value outside permitted range", Expr);
5015 Set_Enumeration_Rep (Elit, Val);
5025 -- Aggregate is fully processed. Now we check that a full set of
5026 -- representations was given, and that they are in range and in order.
5027 -- These checks are only done if no other errors occurred.
5033 Elit := First_Literal (Enumtype);
5034 while Present (Elit) loop
5035 if No (Enumeration_Rep_Expr (Elit)) then
5036 Error_Msg_NE ("missing representation for&!", N, Elit);
5039 Val := Enumeration_Rep (Elit);
5041 if Min = No_Uint then
5045 if Val /= No_Uint then
5046 if Max /= No_Uint and then Val <= Max then
5048 ("enumeration value for& not ordered!",
5049 Enumeration_Rep_Expr (Elit), Elit);
5052 Max_Node := Enumeration_Rep_Expr (Elit);
5056 -- If there is at least one literal whose representation is not
5057 -- equal to the Pos value, then note that this enumeration type
5058 -- has a non-standard representation.
5060 if Val /= Enumeration_Pos (Elit) then
5061 Set_Has_Non_Standard_Rep (Base_Type (Enumtype));
5068 -- Now set proper size information
5071 Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype));
5074 if Has_Size_Clause (Enumtype) then
5076 -- All OK, if size is OK now
5078 if RM_Size (Enumtype) >= Minsize then
5082 -- Try if we can get by with biasing
5085 UI_From_Int (Minimum_Size (Enumtype, Biased => True));
5087 -- Error message if even biasing does not work
5089 if RM_Size (Enumtype) < Minsize then
5090 Error_Msg_Uint_1 := RM_Size (Enumtype);
5091 Error_Msg_Uint_2 := Max;
5093 ("previously given size (^) is too small "
5094 & "for this value (^)", Max_Node);
5096 -- If biasing worked, indicate that we now have biased rep
5100 (Enumtype, Size_Clause (Enumtype), "size clause");
5105 Set_RM_Size (Enumtype, Minsize);
5106 Set_Enum_Esize (Enumtype);
5109 Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype));
5110 Set_Esize (Base_Type (Enumtype), Esize (Enumtype));
5111 Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
5115 -- We repeat the too late test in case it froze itself!
5117 if Rep_Item_Too_Late (Enumtype, N) then
5120 end Analyze_Enumeration_Representation_Clause;
5122 ----------------------------
5123 -- Analyze_Free_Statement --
5124 ----------------------------
5126 procedure Analyze_Free_Statement (N : Node_Id) is
5128 Analyze (Expression (N));
5129 end Analyze_Free_Statement;
5131 ---------------------------
5132 -- Analyze_Freeze_Entity --
5133 ---------------------------
5135 procedure Analyze_Freeze_Entity (N : Node_Id) is
5137 Freeze_Entity_Checks (N);
5138 end Analyze_Freeze_Entity;
5140 -----------------------------------
5141 -- Analyze_Freeze_Generic_Entity --
5142 -----------------------------------
5144 procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is
5146 Freeze_Entity_Checks (N);
5147 end Analyze_Freeze_Generic_Entity;
5149 ------------------------------------------
5150 -- Analyze_Record_Representation_Clause --
5151 ------------------------------------------
5153 -- Note: we check as much as we can here, but we can't do any checks
5154 -- based on the position values (e.g. overlap checks) until freeze time
5155 -- because especially in Ada 2005 (machine scalar mode), the processing
5156 -- for non-standard bit order can substantially change the positions.
5157 -- See procedure Check_Record_Representation_Clause (called from Freeze)
5158 -- for the remainder of this processing.
5160 procedure Analyze_Record_Representation_Clause (N : Node_Id) is
5161 Ident : constant Node_Id := Identifier (N);
5166 Hbit : Uint := Uint_0;
5170 Rectype : Entity_Id;
5173 function Is_Inherited (Comp : Entity_Id) return Boolean;
5174 -- True if Comp is an inherited component in a record extension
5180 function Is_Inherited (Comp : Entity_Id) return Boolean is
5181 Comp_Base : Entity_Id;
5184 if Ekind (Rectype) = E_Record_Subtype then
5185 Comp_Base := Original_Record_Component (Comp);
5190 return Comp_Base /= Original_Record_Component (Comp_Base);
5195 Is_Record_Extension : Boolean;
5196 -- True if Rectype is a record extension
5198 CR_Pragma : Node_Id := Empty;
5199 -- Points to N_Pragma node if Complete_Representation pragma present
5201 -- Start of processing for Analyze_Record_Representation_Clause
5204 if Ignore_Rep_Clauses then
5209 Rectype := Entity (Ident);
5211 if Rectype = Any_Type or else Rep_Item_Too_Early (Rectype, N) then
5214 Rectype := Underlying_Type (Rectype);
5217 -- First some basic error checks
5219 if not Is_Record_Type (Rectype) then
5221 ("record type required, found}", Ident, First_Subtype (Rectype));
5224 elsif Scope (Rectype) /= Current_Scope then
5225 Error_Msg_N ("type must be declared in this scope", N);
5228 elsif not Is_First_Subtype (Rectype) then
5229 Error_Msg_N ("cannot give record rep clause for subtype", N);
5232 elsif Has_Record_Rep_Clause (Rectype) then
5233 Error_Msg_N ("duplicate record rep clause ignored", N);
5236 elsif Rep_Item_Too_Late (Rectype, N) then
5240 -- We know we have a first subtype, now possibly go the the anonymous
5241 -- base type to determine whether Rectype is a record extension.
5243 Recdef := Type_Definition (Declaration_Node (Base_Type (Rectype)));
5244 Is_Record_Extension :=
5245 Nkind (Recdef) = N_Derived_Type_Definition
5246 and then Present (Record_Extension_Part (Recdef));
5248 if Present (Mod_Clause (N)) then
5250 Loc : constant Source_Ptr := Sloc (N);
5251 M : constant Node_Id := Mod_Clause (N);
5252 P : constant List_Id := Pragmas_Before (M);
5256 pragma Warnings (Off, Mod_Val);
5259 Check_Restriction (No_Obsolescent_Features, Mod_Clause (N));
5261 if Warn_On_Obsolescent_Feature then
5263 ("?j?mod clause is an obsolescent feature (RM J.8)", N);
5265 ("\?j?use alignment attribute definition clause instead", N);
5272 -- In ASIS_Mode mode, expansion is disabled, but we must convert
5273 -- the Mod clause into an alignment clause anyway, so that the
5274 -- back-end can compute and back-annotate properly the size and
5275 -- alignment of types that may include this record.
5277 -- This seems dubious, this destroys the source tree in a manner
5278 -- not detectable by ASIS ???
5280 if Operating_Mode = Check_Semantics and then ASIS_Mode then
5282 Make_Attribute_Definition_Clause (Loc,
5283 Name => New_Reference_To (Base_Type (Rectype), Loc),
5284 Chars => Name_Alignment,
5285 Expression => Relocate_Node (Expression (M)));
5287 Set_From_At_Mod (AtM_Nod);
5288 Insert_After (N, AtM_Nod);
5289 Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
5290 Set_Mod_Clause (N, Empty);
5293 -- Get the alignment value to perform error checking
5295 Mod_Val := Get_Alignment_Value (Expression (M));
5300 -- For untagged types, clear any existing component clauses for the
5301 -- type. If the type is derived, this is what allows us to override
5302 -- a rep clause for the parent. For type extensions, the representation
5303 -- of the inherited components is inherited, so we want to keep previous
5304 -- component clauses for completeness.
5306 if not Is_Tagged_Type (Rectype) then
5307 Comp := First_Component_Or_Discriminant (Rectype);
5308 while Present (Comp) loop
5309 Set_Component_Clause (Comp, Empty);
5310 Next_Component_Or_Discriminant (Comp);
5314 -- All done if no component clauses
5316 CC := First (Component_Clauses (N));
5322 -- A representation like this applies to the base type
5324 Set_Has_Record_Rep_Clause (Base_Type (Rectype));
5325 Set_Has_Non_Standard_Rep (Base_Type (Rectype));
5326 Set_Has_Specified_Layout (Base_Type (Rectype));
5328 -- Process the component clauses
5330 while Present (CC) loop
5334 if Nkind (CC) = N_Pragma then
5337 -- The only pragma of interest is Complete_Representation
5339 if Pragma_Name (CC) = Name_Complete_Representation then
5343 -- Processing for real component clause
5346 Posit := Static_Integer (Position (CC));
5347 Fbit := Static_Integer (First_Bit (CC));
5348 Lbit := Static_Integer (Last_Bit (CC));
5351 and then Fbit /= No_Uint
5352 and then Lbit /= No_Uint
5356 ("position cannot be negative", Position (CC));
5360 ("first bit cannot be negative", First_Bit (CC));
5362 -- The Last_Bit specified in a component clause must not be
5363 -- less than the First_Bit minus one (RM-13.5.1(10)).
5365 elsif Lbit < Fbit - 1 then
5367 ("last bit cannot be less than first bit minus one",
5370 -- Values look OK, so find the corresponding record component
5371 -- Even though the syntax allows an attribute reference for
5372 -- implementation-defined components, GNAT does not allow the
5373 -- tag to get an explicit position.
5375 elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
5376 if Attribute_Name (Component_Name (CC)) = Name_Tag then
5377 Error_Msg_N ("position of tag cannot be specified", CC);
5379 Error_Msg_N ("illegal component name", CC);
5383 Comp := First_Entity (Rectype);
5384 while Present (Comp) loop
5385 exit when Chars (Comp) = Chars (Component_Name (CC));
5391 -- Maybe component of base type that is absent from
5392 -- statically constrained first subtype.
5394 Comp := First_Entity (Base_Type (Rectype));
5395 while Present (Comp) loop
5396 exit when Chars (Comp) = Chars (Component_Name (CC));
5403 ("component clause is for non-existent field", CC);
5405 -- Ada 2012 (AI05-0026): Any name that denotes a
5406 -- discriminant of an object of an unchecked union type
5407 -- shall not occur within a record_representation_clause.
5409 -- The general restriction of using record rep clauses on
5410 -- Unchecked_Union types has now been lifted. Since it is
5411 -- possible to introduce a record rep clause which mentions
5412 -- the discriminant of an Unchecked_Union in non-Ada 2012
5413 -- code, this check is applied to all versions of the
5416 elsif Ekind (Comp) = E_Discriminant
5417 and then Is_Unchecked_Union (Rectype)
5420 ("cannot reference discriminant of unchecked union",
5421 Component_Name (CC));
5423 elsif Is_Record_Extension and then Is_Inherited (Comp) then
5425 ("component clause not allowed for inherited "
5426 & "component&", CC, Comp);
5428 elsif Present (Component_Clause (Comp)) then
5430 -- Diagnose duplicate rep clause, or check consistency
5431 -- if this is an inherited component. In a double fault,
5432 -- there may be a duplicate inconsistent clause for an
5433 -- inherited component.
5435 if Scope (Original_Record_Component (Comp)) = Rectype
5436 or else Parent (Component_Clause (Comp)) = N
5438 Error_Msg_Sloc := Sloc (Component_Clause (Comp));
5439 Error_Msg_N ("component clause previously given#", CC);
5443 Rep1 : constant Node_Id := Component_Clause (Comp);
5445 if Intval (Position (Rep1)) /=
5446 Intval (Position (CC))
5447 or else Intval (First_Bit (Rep1)) /=
5448 Intval (First_Bit (CC))
5449 or else Intval (Last_Bit (Rep1)) /=
5450 Intval (Last_Bit (CC))
5453 ("component clause inconsistent "
5454 & "with representation of ancestor", CC);
5456 elsif Warn_On_Redundant_Constructs then
5458 ("?r?redundant confirming component clause "
5459 & "for component!", CC);
5464 -- Normal case where this is the first component clause we
5465 -- have seen for this entity, so set it up properly.
5468 -- Make reference for field in record rep clause and set
5469 -- appropriate entity field in the field identifier.
5472 (Comp, Component_Name (CC), Set_Ref => False);
5473 Set_Entity (Component_Name (CC), Comp);
5475 -- Update Fbit and Lbit to the actual bit number
5477 Fbit := Fbit + UI_From_Int (SSU) * Posit;
5478 Lbit := Lbit + UI_From_Int (SSU) * Posit;
5480 if Has_Size_Clause (Rectype)
5481 and then RM_Size (Rectype) <= Lbit
5484 ("bit number out of range of specified size",
5487 Set_Component_Clause (Comp, CC);
5488 Set_Component_Bit_Offset (Comp, Fbit);
5489 Set_Esize (Comp, 1 + (Lbit - Fbit));
5490 Set_Normalized_First_Bit (Comp, Fbit mod SSU);
5491 Set_Normalized_Position (Comp, Fbit / SSU);
5493 if Warn_On_Overridden_Size
5494 and then Has_Size_Clause (Etype (Comp))
5495 and then RM_Size (Etype (Comp)) /= Esize (Comp)
5498 ("?S?component size overrides size clause for&",
5499 Component_Name (CC), Etype (Comp));
5502 -- This information is also set in the corresponding
5503 -- component of the base type, found by accessing the
5504 -- Original_Record_Component link if it is present.
5506 Ocomp := Original_Record_Component (Comp);
5513 (Component_Name (CC),
5519 (Comp, First_Node (CC), "component clause", Biased);
5521 if Present (Ocomp) then
5522 Set_Component_Clause (Ocomp, CC);
5523 Set_Component_Bit_Offset (Ocomp, Fbit);
5524 Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
5525 Set_Normalized_Position (Ocomp, Fbit / SSU);
5526 Set_Esize (Ocomp, 1 + (Lbit - Fbit));
5528 Set_Normalized_Position_Max
5529 (Ocomp, Normalized_Position (Ocomp));
5531 -- Note: we don't use Set_Biased here, because we
5532 -- already gave a warning above if needed, and we
5533 -- would get a duplicate for the same name here.
5535 Set_Has_Biased_Representation
5536 (Ocomp, Has_Biased_Representation (Comp));
5539 if Esize (Comp) < 0 then
5540 Error_Msg_N ("component size is negative", CC);
5551 -- Check missing components if Complete_Representation pragma appeared
5553 if Present (CR_Pragma) then
5554 Comp := First_Component_Or_Discriminant (Rectype);
5555 while Present (Comp) loop
5556 if No (Component_Clause (Comp)) then
5558 ("missing component clause for &", CR_Pragma, Comp);
5561 Next_Component_Or_Discriminant (Comp);
5564 -- Give missing components warning if required
5566 elsif Warn_On_Unrepped_Components then
5568 Num_Repped_Components : Nat := 0;
5569 Num_Unrepped_Components : Nat := 0;
5572 -- First count number of repped and unrepped components
5574 Comp := First_Component_Or_Discriminant (Rectype);
5575 while Present (Comp) loop
5576 if Present (Component_Clause (Comp)) then
5577 Num_Repped_Components := Num_Repped_Components + 1;
5579 Num_Unrepped_Components := Num_Unrepped_Components + 1;
5582 Next_Component_Or_Discriminant (Comp);
5585 -- We are only interested in the case where there is at least one
5586 -- unrepped component, and at least half the components have rep
5587 -- clauses. We figure that if less than half have them, then the
5588 -- partial rep clause is really intentional. If the component
5589 -- type has no underlying type set at this point (as for a generic
5590 -- formal type), we don't know enough to give a warning on the
5593 if Num_Unrepped_Components > 0
5594 and then Num_Unrepped_Components < Num_Repped_Components
5596 Comp := First_Component_Or_Discriminant (Rectype);
5597 while Present (Comp) loop
5598 if No (Component_Clause (Comp))
5599 and then Comes_From_Source (Comp)
5600 and then Present (Underlying_Type (Etype (Comp)))
5601 and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
5602 or else Size_Known_At_Compile_Time
5603 (Underlying_Type (Etype (Comp))))
5604 and then not Has_Warnings_Off (Rectype)
5606 Error_Msg_Sloc := Sloc (Comp);
5608 ("?C?no component clause given for & declared #",
5612 Next_Component_Or_Discriminant (Comp);
5617 end Analyze_Record_Representation_Clause;
5619 -------------------------------------------
5620 -- Build_Invariant_Procedure_Declaration --
5621 -------------------------------------------
5623 function Build_Invariant_Procedure_Declaration
5624 (Typ : Entity_Id) return Node_Id
5626 Loc : constant Source_Ptr := Sloc (Typ);
5627 Object_Entity : constant Entity_Id :=
5628 Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
5633 Set_Etype (Object_Entity, Typ);
5635 -- Check for duplicate definiations.
5637 if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then
5642 Make_Defining_Identifier (Loc,
5643 Chars => New_External_Name (Chars (Typ), "Invariant"));
5644 Set_Has_Invariants (Typ);
5645 Set_Ekind (SId, E_Procedure);
5646 Set_Is_Invariant_Procedure (SId);
5647 Set_Invariant_Procedure (Typ, SId);
5650 Make_Procedure_Specification (Loc,
5651 Defining_Unit_Name => SId,
5652 Parameter_Specifications => New_List (
5653 Make_Parameter_Specification (Loc,
5654 Defining_Identifier => Object_Entity,
5655 Parameter_Type => New_Occurrence_Of (Typ, Loc))));
5657 return Make_Subprogram_Declaration (Loc, Specification => Spec);
5658 end Build_Invariant_Procedure_Declaration;
5660 -------------------------------
5661 -- Build_Invariant_Procedure --
5662 -------------------------------
5664 -- The procedure that is constructed here has the form
5666 -- procedure typInvariant (Ixxx : typ) is
5668 -- pragma Check (Invariant, exp, "failed invariant from xxx");
5669 -- pragma Check (Invariant, exp, "failed invariant from xxx");
5671 -- pragma Check (Invariant, exp, "failed inherited invariant from xxx");
5673 -- end typInvariant;
5675 procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is
5676 Loc : constant Source_Ptr := Sloc (Typ);
5683 Visible_Decls : constant List_Id := Visible_Declarations (N);
5684 Private_Decls : constant List_Id := Private_Declarations (N);
5686 procedure Add_Invariants (T : Entity_Id; Inherit : Boolean);
5687 -- Appends statements to Stmts for any invariants in the rep item chain
5688 -- of the given type. If Inherit is False, then we only process entries
5689 -- on the chain for the type Typ. If Inherit is True, then we ignore any
5690 -- Invariant aspects, but we process all Invariant'Class aspects, adding
5691 -- "inherited" to the exception message and generating an informational
5692 -- message about the inheritance of an invariant.
5694 Object_Name : Name_Id;
5695 -- Name for argument of invariant procedure
5697 Object_Entity : Node_Id;
5698 -- The entity of the formal for the procedure
5700 --------------------
5701 -- Add_Invariants --
5702 --------------------
5704 procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is
5714 procedure Replace_Type_Reference (N : Node_Id);
5715 -- Replace a single occurrence N of the subtype name with a reference
5716 -- to the formal of the predicate function. N can be an identifier
5717 -- referencing the subtype, or a selected component, representing an
5718 -- appropriately qualified occurrence of the subtype name.
5720 procedure Replace_Type_References is
5721 new Replace_Type_References_Generic (Replace_Type_Reference);
5722 -- Traverse an expression replacing all occurrences of the subtype
5723 -- name with appropriate references to the object that is the formal
5724 -- parameter of the predicate function. Note that we must ensure
5725 -- that the type and entity information is properly set in the
5726 -- replacement node, since we will do a Preanalyze call of this
5727 -- expression without proper visibility of the procedure argument.
5729 ----------------------------
5730 -- Replace_Type_Reference --
5731 ----------------------------
5733 -- Note: See comments in Add_Predicates.Replace_Type_Reference
5734 -- regarding handling of Sloc and Comes_From_Source.
5736 procedure Replace_Type_Reference (N : Node_Id) is
5738 -- Invariant'Class, replace with T'Class (obj)
5740 if Class_Present (Ritem) then
5742 Make_Type_Conversion (Sloc (N),
5744 Make_Attribute_Reference (Sloc (N),
5745 Prefix => New_Occurrence_Of (T, Sloc (N)),
5746 Attribute_Name => Name_Class),
5747 Expression => Make_Identifier (Sloc (N), Object_Name)));
5749 Set_Entity (Expression (N), Object_Entity);
5750 Set_Etype (Expression (N), Typ);
5752 -- Invariant, replace with obj
5755 Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
5756 Set_Entity (N, Object_Entity);
5760 Set_Comes_From_Source (N, True);
5761 end Replace_Type_Reference;
5763 -- Start of processing for Add_Invariants
5766 Ritem := First_Rep_Item (T);
5767 while Present (Ritem) loop
5768 if Nkind (Ritem) = N_Pragma
5769 and then Pragma_Name (Ritem) = Name_Invariant
5771 Arg1 := First (Pragma_Argument_Associations (Ritem));
5772 Arg2 := Next (Arg1);
5773 Arg3 := Next (Arg2);
5775 Arg1 := Get_Pragma_Arg (Arg1);
5776 Arg2 := Get_Pragma_Arg (Arg2);
5778 -- For Inherit case, ignore Invariant, process only Class case
5781 if not Class_Present (Ritem) then
5785 -- For Inherit false, process only item for right type
5788 if Entity (Arg1) /= Typ then
5794 Stmts := Empty_List;
5797 Exp := New_Copy_Tree (Arg2);
5799 -- Preserve sloc of original pragma Invariant
5801 Loc := Sloc (Ritem);
5803 -- We need to replace any occurrences of the name of the type
5804 -- with references to the object, converted to type'Class in
5805 -- the case of Invariant'Class aspects.
5807 Replace_Type_References (Exp, Chars (T));
5809 -- If this invariant comes from an aspect, find the aspect
5810 -- specification, and replace the saved expression because
5811 -- we need the subtype references replaced for the calls to
5812 -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
5813 -- and Check_Aspect_At_End_Of_Declarations.
5815 if From_Aspect_Specification (Ritem) then
5820 -- Loop to find corresponding aspect, note that this
5821 -- must be present given the pragma is marked delayed.
5823 Aitem := Next_Rep_Item (Ritem);
5824 while Present (Aitem) loop
5825 if Nkind (Aitem) = N_Aspect_Specification
5826 and then Aspect_Rep_Item (Aitem) = Ritem
5829 (Identifier (Aitem), New_Copy_Tree (Exp));
5833 Aitem := Next_Rep_Item (Aitem);
5838 -- Now we need to preanalyze the expression to properly capture
5839 -- the visibility in the visible part. The expression will not
5840 -- be analyzed for real until the body is analyzed, but that is
5841 -- at the end of the private part and has the wrong visibility.
5843 Set_Parent (Exp, N);
5844 Preanalyze_Assert_Expression (Exp, Standard_Boolean);
5846 -- Build first two arguments for Check pragma
5849 Make_Pragma_Argument_Association (Loc,
5850 Expression => Make_Identifier (Loc, Name_Invariant)),
5851 Make_Pragma_Argument_Association (Loc,
5852 Expression => Exp));
5854 -- Add message if present in Invariant pragma
5856 if Present (Arg3) then
5857 Str := Strval (Get_Pragma_Arg (Arg3));
5859 -- If inherited case, and message starts "failed invariant",
5860 -- change it to be "failed inherited invariant".
5863 String_To_Name_Buffer (Str);
5865 if Name_Buffer (1 .. 16) = "failed invariant" then
5866 Insert_Str_In_Name_Buffer ("inherited ", 8);
5867 Str := String_From_Name_Buffer;
5872 Make_Pragma_Argument_Association (Loc,
5873 Expression => Make_String_Literal (Loc, Str)));
5876 -- Add Check pragma to list of statements
5880 Pragma_Identifier =>
5881 Make_Identifier (Loc, Name_Check),
5882 Pragma_Argument_Associations => Assoc));
5884 -- If Inherited case and option enabled, output info msg. Note
5885 -- that we know this is a case of Invariant'Class.
5887 if Inherit and Opt.List_Inherited_Aspects then
5888 Error_Msg_Sloc := Sloc (Ritem);
5890 ("?L?info: & inherits `Invariant''Class` aspect from #",
5896 Next_Rep_Item (Ritem);
5900 -- Start of processing for Build_Invariant_Procedure
5908 -- If the aspect specification exists for some view of the type, the
5909 -- declaration for the procedure has been created.
5911 if Has_Invariants (Typ) then
5912 SId := Invariant_Procedure (Typ);
5915 if Present (SId) then
5916 PDecl := Unit_Declaration_Node (SId);
5919 PDecl := Build_Invariant_Procedure_Declaration (Typ);
5922 -- Recover formal of procedure, for use in the calls to invariant
5923 -- functions (including inherited ones).
5927 (First (Parameter_Specifications (Specification (PDecl))));
5928 Object_Name := Chars (Object_Entity);
5930 -- Add invariants for the current type
5932 Add_Invariants (Typ, Inherit => False);
5934 -- Add invariants for parent types
5937 Current_Typ : Entity_Id;
5938 Parent_Typ : Entity_Id;
5943 Parent_Typ := Etype (Current_Typ);
5945 if Is_Private_Type (Parent_Typ)
5946 and then Present (Full_View (Base_Type (Parent_Typ)))
5948 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5951 exit when Parent_Typ = Current_Typ;
5953 Current_Typ := Parent_Typ;
5954 Add_Invariants (Current_Typ, Inherit => True);
5958 -- Build the procedure if we generated at least one Check pragma
5960 if Stmts /= No_List then
5961 Spec := Copy_Separate_Tree (Specification (PDecl));
5964 Make_Subprogram_Body (Loc,
5965 Specification => Spec,
5966 Declarations => Empty_List,
5967 Handled_Statement_Sequence =>
5968 Make_Handled_Sequence_Of_Statements (Loc,
5969 Statements => Stmts));
5971 -- Insert procedure declaration and spec at the appropriate points.
5972 -- If declaration is already analyzed, it was processed by the
5973 -- generated pragma.
5975 if Present (Private_Decls) then
5977 -- The spec goes at the end of visible declarations, but they have
5978 -- already been analyzed, so we need to explicitly do the analyze.
5980 if not Analyzed (PDecl) then
5981 Append_To (Visible_Decls, PDecl);
5985 -- The body goes at the end of the private declarations, which we
5986 -- have not analyzed yet, so we do not need to perform an explicit
5987 -- analyze call. We skip this if there are no private declarations
5988 -- (this is an error that will be caught elsewhere);
5990 Append_To (Private_Decls, PBody);
5992 -- If the invariant appears on the full view of a type, the
5993 -- analysis of the private part is complete, and we must
5994 -- analyze the new body explicitly.
5996 if In_Private_Part (Current_Scope) then
6000 -- If there are no private declarations this may be an error that
6001 -- will be diagnosed elsewhere. However, if this is a non-private
6002 -- type that inherits invariants, it needs no completion and there
6003 -- may be no private part. In this case insert invariant procedure
6004 -- at end of current declarative list, and analyze at once, given
6005 -- that the type is about to be frozen.
6007 elsif not Is_Private_Type (Typ) then
6008 Append_To (Visible_Decls, PDecl);
6009 Append_To (Visible_Decls, PBody);
6014 end Build_Invariant_Procedure;
6016 -------------------------------
6017 -- Build_Predicate_Functions --
6018 -------------------------------
6020 -- The procedures that are constructed here have the form:
6022 -- function typPredicate (Ixxx : typ) return Boolean is
6025 -- exp1 and then exp2 and then ...
6026 -- and then typ1Predicate (typ1 (Ixxx))
6027 -- and then typ2Predicate (typ2 (Ixxx))
6029 -- end typPredicate;
6031 -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
6032 -- this is the point at which these expressions get analyzed, providing the
6033 -- required delay, and typ1, typ2, are entities from which predicates are
6034 -- inherited. Note that we do NOT generate Check pragmas, that's because we
6035 -- use this function even if checks are off, e.g. for membership tests.
6037 -- If the expression has at least one Raise_Expression, then we also build
6038 -- the typPredicateM version of the function, in which any occurrence of a
6039 -- Raise_Expression is converted to "return False".
6041 procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is
6042 Loc : constant Source_Ptr := Sloc (Typ);
6045 -- This is the expression for the result of the function. It is
6046 -- is build by connecting the component predicates with AND THEN.
6049 -- This is the corresponding return expression for the Predicate_M
6050 -- function. It differs in that raise expressions are marked for
6051 -- special expansion (see Process_REs).
6053 Object_Name : constant Name_Id := New_Internal_Name ('I');
6054 -- Name for argument of Predicate procedure. Note that we use the same
6055 -- name for both predicate procedure. That way the reference within the
6056 -- predicate expression is the same in both functions.
6058 Object_Entity : constant Entity_Id :=
6059 Make_Defining_Identifier (Loc, Chars => Object_Name);
6060 -- Entity for argument of Predicate procedure
6062 Object_Entity_M : constant Entity_Id :=
6063 Make_Defining_Identifier (Loc, Chars => Object_Name);
6064 -- Entity for argument of Predicate_M procedure
6066 Raise_Expression_Present : Boolean := False;
6067 -- Set True if Expr has at least one Raise_Expression
6069 Static_Predic : Node_Id := Empty;
6070 -- Set to N_Pragma node for a static predicate if one is encountered
6072 procedure Add_Call (T : Entity_Id);
6073 -- Includes a call to the predicate function for type T in Expr if T
6074 -- has predicates and Predicate_Function (T) is non-empty.
6076 procedure Add_Predicates;
6077 -- Appends expressions for any Predicate pragmas in the rep item chain
6078 -- Typ to Expr. Note that we look only at items for this exact entity.
6079 -- Inheritance of predicates for the parent type is done by calling the
6080 -- Predicate_Function of the parent type, using Add_Call above.
6082 function Test_RE (N : Node_Id) return Traverse_Result;
6083 -- Used in Test_REs, tests one node for being a raise expression, and if
6084 -- so sets Raise_Expression_Present True.
6086 procedure Test_REs is new Traverse_Proc (Test_RE);
6087 -- Tests to see if Expr contains any raise expressions
6089 function Process_RE (N : Node_Id) return Traverse_Result;
6090 -- Used in Process REs, tests if node N is a raise expression, and if
6091 -- so, marks it to be converted to return False.
6093 procedure Process_REs is new Traverse_Proc (Process_RE);
6094 -- Marks any raise expressions in Expr_M to return False
6100 procedure Add_Call (T : Entity_Id) is
6104 if Present (T) and then Present (Predicate_Function (T)) then
6105 Set_Has_Predicates (Typ);
6107 -- Build the call to the predicate function of T
6111 (T, Convert_To (T, Make_Identifier (Loc, Object_Name)));
6113 -- Add call to evolving expression, using AND THEN if needed
6120 Left_Opnd => Relocate_Node (Expr),
6124 -- Output info message on inheritance if required. Note we do not
6125 -- give this information for generic actual types, since it is
6126 -- unwelcome noise in that case in instantiations. We also
6127 -- generally suppress the message in instantiations, and also
6128 -- if it involves internal names.
6130 if Opt.List_Inherited_Aspects
6131 and then not Is_Generic_Actual_Type (Typ)
6132 and then Instantiation_Depth (Sloc (Typ)) = 0
6133 and then not Is_Internal_Name (Chars (T))
6134 and then not Is_Internal_Name (Chars (Typ))
6136 Error_Msg_Sloc := Sloc (Predicate_Function (T));
6137 Error_Msg_Node_2 := T;
6138 Error_Msg_N ("info: & inherits predicate from & #?L?", Typ);
6143 --------------------
6144 -- Add_Predicates --
6145 --------------------
6147 procedure Add_Predicates is
6152 procedure Replace_Type_Reference (N : Node_Id);
6153 -- Replace a single occurrence N of the subtype name with a reference
6154 -- to the formal of the predicate function. N can be an identifier
6155 -- referencing the subtype, or a selected component, representing an
6156 -- appropriately qualified occurrence of the subtype name.
6158 procedure Replace_Type_References is
6159 new Replace_Type_References_Generic (Replace_Type_Reference);
6160 -- Traverse an expression changing every occurrence of an identifier
6161 -- whose name matches the name of the subtype with a reference to
6162 -- the formal parameter of the predicate function.
6164 ----------------------------
6165 -- Replace_Type_Reference --
6166 ----------------------------
6168 procedure Replace_Type_Reference (N : Node_Id) is
6170 Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
6171 -- Use the Sloc of the usage name, not the defining name
6174 Set_Entity (N, Object_Entity);
6176 -- We want to treat the node as if it comes from source, so that
6177 -- ASIS will not ignore it
6179 Set_Comes_From_Source (N, True);
6180 end Replace_Type_Reference;
6182 -- Start of processing for Add_Predicates
6185 Ritem := First_Rep_Item (Typ);
6186 while Present (Ritem) loop
6187 if Nkind (Ritem) = N_Pragma
6188 and then Pragma_Name (Ritem) = Name_Predicate
6190 -- Save the static predicate of the type for diagnostics and
6191 -- error reporting purposes.
6193 if Present (Corresponding_Aspect (Ritem))
6194 and then Chars (Identifier (Corresponding_Aspect (Ritem))) =
6195 Name_Static_Predicate
6197 Static_Predic := Ritem;
6200 -- Acquire arguments
6202 Arg1 := First (Pragma_Argument_Associations (Ritem));
6203 Arg2 := Next (Arg1);
6205 Arg1 := Get_Pragma_Arg (Arg1);
6206 Arg2 := Get_Pragma_Arg (Arg2);
6208 -- See if this predicate pragma is for the current type or for
6209 -- its full view. A predicate on a private completion is placed
6210 -- on the partial view beause this is the visible entity that
6213 if Entity (Arg1) = Typ
6214 or else Full_View (Entity (Arg1)) = Typ
6216 -- We have a match, this entry is for our subtype
6218 -- We need to replace any occurrences of the name of the
6219 -- type with references to the object.
6221 Replace_Type_References (Arg2, Chars (Typ));
6223 -- If this predicate comes from an aspect, find the aspect
6224 -- specification, and replace the saved expression because
6225 -- we need the subtype references replaced for the calls to
6226 -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
6227 -- and Check_Aspect_At_End_Of_Declarations.
6229 if From_Aspect_Specification (Ritem) then
6234 -- Loop to find corresponding aspect, note that this
6235 -- must be present given the pragma is marked delayed.
6237 Aitem := Next_Rep_Item (Ritem);
6239 if Nkind (Aitem) = N_Aspect_Specification
6240 and then Aspect_Rep_Item (Aitem) = Ritem
6243 (Identifier (Aitem), New_Copy_Tree (Arg2));
6247 Aitem := Next_Rep_Item (Aitem);
6252 -- Now we can add the expression
6255 Expr := Relocate_Node (Arg2);
6257 -- There already was a predicate, so add to it
6262 Left_Opnd => Relocate_Node (Expr),
6263 Right_Opnd => Relocate_Node (Arg2));
6268 Next_Rep_Item (Ritem);
6276 function Process_RE (N : Node_Id) return Traverse_Result is
6278 if Nkind (N) = N_Raise_Expression then
6279 Set_Convert_To_Return_False (N);
6290 function Test_RE (N : Node_Id) return Traverse_Result is
6292 if Nkind (N) = N_Raise_Expression then
6293 Raise_Expression_Present := True;
6300 -- Start of processing for Build_Predicate_Functions
6303 -- Return if already built or if type does not have predicates
6305 if not Has_Predicates (Typ)
6306 or else Present (Predicate_Function (Typ))
6311 -- Prepare to construct predicate expression
6315 -- Add Predicates for the current type
6319 -- Add predicates for ancestor if present
6322 Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
6324 if Present (Atyp) then
6329 -- Case where predicates are present
6331 if Present (Expr) then
6333 -- Test for raise expression present
6337 -- If raise expression is present, capture a copy of Expr for use
6338 -- in building the predicateM function version later on. For this
6339 -- copy we replace references to Object_Entity by Object_Entity_M.
6341 if Raise_Expression_Present then
6343 Map : constant Elist_Id := New_Elmt_List;
6345 Append_Elmt (Object_Entity, Map);
6346 Append_Elmt (Object_Entity_M, Map);
6347 Expr_M := New_Copy_Tree (Expr, Map => Map);
6351 -- Build the main predicate function
6354 SId : constant Entity_Id :=
6355 Make_Defining_Identifier (Loc,
6356 Chars => New_External_Name (Chars (Typ), "Predicate"));
6357 -- The entity for the the function spec
6359 SIdB : constant Entity_Id :=
6360 Make_Defining_Identifier (Loc,
6361 Chars => New_External_Name (Chars (Typ), "Predicate"));
6362 -- The entity for the function body
6369 -- Build function declaration
6371 Set_Ekind (SId, E_Function);
6372 Set_Is_Predicate_Function (SId);
6373 Set_Predicate_Function (Typ, SId);
6375 -- The predicate function is shared between views of a type
6377 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
6378 Set_Predicate_Function (Full_View (Typ), SId);
6382 Make_Function_Specification (Loc,
6383 Defining_Unit_Name => SId,
6384 Parameter_Specifications => New_List (
6385 Make_Parameter_Specification (Loc,
6386 Defining_Identifier => Object_Entity,
6387 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
6388 Result_Definition =>
6389 New_Occurrence_Of (Standard_Boolean, Loc));
6392 Make_Subprogram_Declaration (Loc,
6393 Specification => Spec);
6395 -- Build function body
6398 Make_Function_Specification (Loc,
6399 Defining_Unit_Name => SIdB,
6400 Parameter_Specifications => New_List (
6401 Make_Parameter_Specification (Loc,
6402 Defining_Identifier =>
6403 Make_Defining_Identifier (Loc, Object_Name),
6405 New_Occurrence_Of (Typ, Loc))),
6406 Result_Definition =>
6407 New_Occurrence_Of (Standard_Boolean, Loc));
6410 Make_Subprogram_Body (Loc,
6411 Specification => Spec,
6412 Declarations => Empty_List,
6413 Handled_Statement_Sequence =>
6414 Make_Handled_Sequence_Of_Statements (Loc,
6415 Statements => New_List (
6416 Make_Simple_Return_Statement (Loc,
6417 Expression => Expr))));
6419 -- Insert declaration before freeze node and body after
6421 Insert_Before_And_Analyze (N, FDecl);
6422 Insert_After_And_Analyze (N, FBody);
6425 -- Test for raise expressions present and if so build M version
6427 if Raise_Expression_Present then
6429 SId : constant Entity_Id :=
6430 Make_Defining_Identifier (Loc,
6431 Chars => New_External_Name (Chars (Typ), "PredicateM"));
6432 -- The entity for the the function spec
6434 SIdB : constant Entity_Id :=
6435 Make_Defining_Identifier (Loc,
6436 Chars => New_External_Name (Chars (Typ), "PredicateM"));
6437 -- The entity for the function body
6445 -- Mark any raise expressions for special expansion
6447 Process_REs (Expr_M);
6449 -- Build function declaration
6451 Set_Ekind (SId, E_Function);
6452 Set_Is_Predicate_Function_M (SId);
6453 Set_Predicate_Function_M (Typ, SId);
6455 -- The predicate function is shared between views of a type
6457 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
6458 Set_Predicate_Function_M (Full_View (Typ), SId);
6462 Make_Function_Specification (Loc,
6463 Defining_Unit_Name => SId,
6464 Parameter_Specifications => New_List (
6465 Make_Parameter_Specification (Loc,
6466 Defining_Identifier => Object_Entity_M,
6467 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
6468 Result_Definition =>
6469 New_Occurrence_Of (Standard_Boolean, Loc));
6472 Make_Subprogram_Declaration (Loc,
6473 Specification => Spec);
6475 -- Build function body
6478 Make_Function_Specification (Loc,
6479 Defining_Unit_Name => SIdB,
6480 Parameter_Specifications => New_List (
6481 Make_Parameter_Specification (Loc,
6482 Defining_Identifier =>
6483 Make_Defining_Identifier (Loc, Object_Name),
6485 New_Occurrence_Of (Typ, Loc))),
6486 Result_Definition =>
6487 New_Occurrence_Of (Standard_Boolean, Loc));
6489 -- Build the body, we declare the boolean expression before
6490 -- doing the return, because we are not really confident of
6491 -- what happens if a return appears within a return!
6494 Make_Defining_Identifier (Loc,
6495 Chars => New_Internal_Name ('B'));
6498 Make_Subprogram_Body (Loc,
6499 Specification => Spec,
6501 Declarations => New_List (
6502 Make_Object_Declaration (Loc,
6503 Defining_Identifier => BTemp,
6504 Constant_Present => True,
6505 Object_Definition =>
6506 New_Reference_To (Standard_Boolean, Loc),
6507 Expression => Expr_M)),
6509 Handled_Statement_Sequence =>
6510 Make_Handled_Sequence_Of_Statements (Loc,
6511 Statements => New_List (
6512 Make_Simple_Return_Statement (Loc,
6513 Expression => New_Reference_To (BTemp, Loc)))));
6515 -- Insert declaration before freeze node and body after
6517 Insert_Before_And_Analyze (N, FDecl);
6518 Insert_After_And_Analyze (N, FBody);
6522 if Is_Scalar_Type (Typ) then
6524 -- Attempt to build a static predicate for a discrete or a real
6525 -- subtype. This action may fail because the actual expression may
6526 -- not be static. Note that the presence of an inherited or
6527 -- explicitly declared dynamic predicate is orthogonal to this
6528 -- check because we are only interested in the static predicate.
6530 if Ekind_In (Typ, E_Decimal_Fixed_Point_Subtype,
6531 E_Enumeration_Subtype,
6532 E_Floating_Point_Subtype,
6533 E_Modular_Integer_Subtype,
6534 E_Ordinary_Fixed_Point_Subtype,
6535 E_Signed_Integer_Subtype)
6537 Build_Static_Predicate (Typ, Expr, Object_Name);
6539 -- Emit an error when the predicate is categorized as static
6540 -- but its expression is dynamic.
6542 if Present (Static_Predic)
6543 and then No (Static_Predicate (Typ))
6546 ("expression does not have required form for "
6547 & "static predicate",
6548 Next (First (Pragma_Argument_Associations
6553 -- If a static predicate applies on other types, that's an error:
6554 -- either the type is scalar but non-static, or it's not even a
6555 -- scalar type. We do not issue an error on generated types, as
6556 -- these may be duplicates of the same error on a source type.
6558 elsif Present (Static_Predic) and then Comes_From_Source (Typ) then
6559 if Is_Scalar_Type (Typ) then
6561 ("static predicate not allowed for non-static type&",
6565 ("static predicate not allowed for non-scalar type&",
6570 end Build_Predicate_Functions;
6572 ----------------------------
6573 -- Build_Static_Predicate --
6574 ----------------------------
6576 procedure Build_Static_Predicate
6581 Loc : constant Source_Ptr := Sloc (Expr);
6583 Non_Static : exception;
6584 -- Raised if something non-static is found
6586 Btyp : constant Entity_Id := Base_Type (Typ);
6588 BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp));
6589 BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
6590 -- Low bound and high bound value of base type of Typ
6592 TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ));
6593 THi : constant Uint := Expr_Value (Type_High_Bound (Typ));
6594 -- Low bound and high bound values of static subtype Typ
6599 -- One entry in a Rlist value, a single REnt (range entry) value denotes
6600 -- one range from Lo to Hi. To represent a single value range Lo = Hi =
6603 type RList is array (Nat range <>) of REnt;
6604 -- A list of ranges. The ranges are sorted in increasing order, and are
6605 -- disjoint (there is a gap of at least one value between each range in
6606 -- the table). A value is in the set of ranges in Rlist if it lies
6607 -- within one of these ranges.
6609 False_Range : constant RList :=
6610 RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
6611 -- An empty set of ranges represents a range list that can never be
6612 -- satisfied, since there are no ranges in which the value could lie,
6613 -- so it does not lie in any of them. False_Range is a canonical value
6614 -- for this empty set, but general processing should test for an Rlist
6615 -- with length zero (see Is_False predicate), since other null ranges
6616 -- may appear which must be treated as False.
6618 True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
6619 -- Range representing True, value must be in the base range
6621 function "and" (Left : RList; Right : RList) return RList;
6622 -- And's together two range lists, returning a range list. This is a set
6623 -- intersection operation.
6625 function "or" (Left : RList; Right : RList) return RList;
6626 -- Or's together two range lists, returning a range list. This is a set
6629 function "not" (Right : RList) return RList;
6630 -- Returns complement of a given range list, i.e. a range list
6631 -- representing all the values in TLo .. THi that are not in the input
6634 function Build_Val (V : Uint) return Node_Id;
6635 -- Return an analyzed N_Identifier node referencing this value, suitable
6636 -- for use as an entry in the Static_Predicate list. This node is typed
6637 -- with the base type.
6639 function Build_Range (Lo : Uint; Hi : Uint) return Node_Id;
6640 -- Return an analyzed N_Range node referencing this range, suitable for
6641 -- use as an entry in the Static_Predicate list. This node is typed with
6644 function Get_RList (Exp : Node_Id) return RList;
6645 -- This is a recursive routine that converts the given expression into a
6646 -- list of ranges, suitable for use in building the static predicate.
6648 function Is_False (R : RList) return Boolean;
6649 pragma Inline (Is_False);
6650 -- Returns True if the given range list is empty, and thus represents a
6651 -- False list of ranges that can never be satisfied.
6653 function Is_True (R : RList) return Boolean;
6654 -- Returns True if R trivially represents the True predicate by having a
6655 -- single range from BLo to BHi.
6657 function Is_Type_Ref (N : Node_Id) return Boolean;
6658 pragma Inline (Is_Type_Ref);
6659 -- Returns if True if N is a reference to the type for the predicate in
6660 -- the expression (i.e. if it is an identifier whose Chars field matches
6661 -- the Nam given in the call).
6663 function Lo_Val (N : Node_Id) return Uint;
6664 -- Given static expression or static range from a Static_Predicate list,
6665 -- gets expression value or low bound of range.
6667 function Hi_Val (N : Node_Id) return Uint;
6668 -- Given static expression or static range from a Static_Predicate list,
6669 -- gets expression value of high bound of range.
6671 function Membership_Entry (N : Node_Id) return RList;
6672 -- Given a single membership entry (range, value, or subtype), returns
6673 -- the corresponding range list. Raises Static_Error if not static.
6675 function Membership_Entries (N : Node_Id) return RList;
6676 -- Given an element on an alternatives list of a membership operation,
6677 -- returns the range list corresponding to this entry and all following
6678 -- entries (i.e. returns the "or" of this list of values).
6680 function Stat_Pred (Typ : Entity_Id) return RList;
6681 -- Given a type, if it has a static predicate, then return the predicate
6682 -- as a range list, otherwise raise Non_Static.
6688 function "and" (Left : RList; Right : RList) return RList is
6690 -- First range of result
6692 SLeft : Nat := Left'First;
6693 -- Start of rest of left entries
6695 SRight : Nat := Right'First;
6696 -- Start of rest of right entries
6699 -- If either range is True, return the other
6701 if Is_True (Left) then
6703 elsif Is_True (Right) then
6707 -- If either range is False, return False
6709 if Is_False (Left) or else Is_False (Right) then
6713 -- Loop to remove entries at start that are disjoint, and thus just
6714 -- get discarded from the result entirely.
6717 -- If no operands left in either operand, result is false
6719 if SLeft > Left'Last or else SRight > Right'Last then
6722 -- Discard first left operand entry if disjoint with right
6724 elsif Left (SLeft).Hi < Right (SRight).Lo then
6727 -- Discard first right operand entry if disjoint with left
6729 elsif Right (SRight).Hi < Left (SLeft).Lo then
6730 SRight := SRight + 1;
6732 -- Otherwise we have an overlapping entry
6739 -- Now we have two non-null operands, and first entries overlap. The
6740 -- first entry in the result will be the overlapping part of these
6743 FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
6744 Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
6746 -- Now we can remove the entry that ended at a lower value, since its
6747 -- contribution is entirely contained in Fent.
6749 if Left (SLeft).Hi <= Right (SRight).Hi then
6752 SRight := SRight + 1;
6755 -- Compute result by concatenating this first entry with the "and" of
6756 -- the remaining parts of the left and right operands. Note that if
6757 -- either of these is empty, "and" will yield empty, so that we will
6758 -- end up with just Fent, which is what we want in that case.
6761 FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
6768 function "not" (Right : RList) return RList is
6770 -- Return True if False range
6772 if Is_False (Right) then
6776 -- Return False if True range
6778 if Is_True (Right) then
6782 -- Here if not trivial case
6785 Result : RList (1 .. Right'Length + 1);
6786 -- May need one more entry for gap at beginning and end
6789 -- Number of entries stored in Result
6794 if Right (Right'First).Lo > TLo then
6796 Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1);
6799 -- Gaps between ranges
6801 for J in Right'First .. Right'Last - 1 loop
6804 REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
6809 if Right (Right'Last).Hi < THi then
6811 Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi);
6814 return Result (1 .. Count);
6822 function "or" (Left : RList; Right : RList) return RList is
6824 -- First range of result
6826 SLeft : Nat := Left'First;
6827 -- Start of rest of left entries
6829 SRight : Nat := Right'First;
6830 -- Start of rest of right entries
6833 -- If either range is True, return True
6835 if Is_True (Left) or else Is_True (Right) then
6839 -- If either range is False (empty), return the other
6841 if Is_False (Left) then
6843 elsif Is_False (Right) then
6847 -- Initialize result first entry from left or right operand depending
6848 -- on which starts with the lower range.
6850 if Left (SLeft).Lo < Right (SRight).Lo then
6851 FEnt := Left (SLeft);
6854 FEnt := Right (SRight);
6855 SRight := SRight + 1;
6858 -- This loop eats ranges from left and right operands that are
6859 -- contiguous with the first range we are gathering.
6862 -- Eat first entry in left operand if contiguous or overlapped by
6863 -- gathered first operand of result.
6865 if SLeft <= Left'Last
6866 and then Left (SLeft).Lo <= FEnt.Hi + 1
6868 FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
6871 -- Eat first entry in right operand if contiguous or overlapped by
6872 -- gathered right operand of result.
6874 elsif SRight <= Right'Last
6875 and then Right (SRight).Lo <= FEnt.Hi + 1
6877 FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
6878 SRight := SRight + 1;
6880 -- All done if no more entries to eat
6887 -- Obtain result as the first entry we just computed, concatenated
6888 -- to the "or" of the remaining results (if one operand is empty,
6889 -- this will just concatenate with the other
6892 FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
6899 function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is
6905 Low_Bound => Build_Val (Lo),
6906 High_Bound => Build_Val (Hi));
6907 Set_Etype (Result, Btyp);
6908 Set_Analyzed (Result);
6917 function Build_Val (V : Uint) return Node_Id is
6921 if Is_Enumeration_Type (Typ) then
6922 Result := Get_Enum_Lit_From_Pos (Typ, V, Loc);
6924 Result := Make_Integer_Literal (Loc, V);
6927 Set_Etype (Result, Btyp);
6928 Set_Is_Static_Expression (Result);
6929 Set_Analyzed (Result);
6937 function Get_RList (Exp : Node_Id) return RList is
6942 -- Static expression can only be true or false
6944 if Is_OK_Static_Expression (Exp) then
6948 if Expr_Value (Exp) = 0 then
6955 -- Otherwise test node type
6963 when N_Op_And | N_And_Then =>
6964 return Get_RList (Left_Opnd (Exp))
6966 Get_RList (Right_Opnd (Exp));
6970 when N_Op_Or | N_Or_Else =>
6971 return Get_RList (Left_Opnd (Exp))
6973 Get_RList (Right_Opnd (Exp));
6978 return not Get_RList (Right_Opnd (Exp));
6980 -- Comparisons of type with static value
6982 when N_Op_Compare =>
6984 -- Type is left operand
6986 if Is_Type_Ref (Left_Opnd (Exp))
6987 and then Is_OK_Static_Expression (Right_Opnd (Exp))
6989 Val := Expr_Value (Right_Opnd (Exp));
6991 -- Typ is right operand
6993 elsif Is_Type_Ref (Right_Opnd (Exp))
6994 and then Is_OK_Static_Expression (Left_Opnd (Exp))
6996 Val := Expr_Value (Left_Opnd (Exp));
6998 -- Invert sense of comparison
7001 when N_Op_Gt => Op := N_Op_Lt;
7002 when N_Op_Lt => Op := N_Op_Gt;
7003 when N_Op_Ge => Op := N_Op_Le;
7004 when N_Op_Le => Op := N_Op_Ge;
7005 when others => null;
7008 -- Other cases are non-static
7014 -- Construct range according to comparison operation
7018 return RList'(1 => REnt'(Val, Val));
7021 return RList'(1 => REnt'(Val, BHi));
7024 return RList'(1 => REnt'(Val + 1, BHi));
7027 return RList'(1 => REnt'(BLo, Val));
7030 return RList'(1 => REnt'(BLo, Val - 1));
7033 return RList'(REnt'(BLo, Val - 1),
7034 REnt'(Val + 1, BHi));
7037 raise Program_Error;
7043 if not Is_Type_Ref (Left_Opnd (Exp)) then
7047 if Present (Right_Opnd (Exp)) then
7048 return Membership_Entry (Right_Opnd (Exp));
7050 return Membership_Entries (First (Alternatives (Exp)));
7053 -- Negative membership (NOT IN)
7056 if not Is_Type_Ref (Left_Opnd (Exp)) then
7060 if Present (Right_Opnd (Exp)) then
7061 return not Membership_Entry (Right_Opnd (Exp));
7063 return not Membership_Entries (First (Alternatives (Exp)));
7066 -- Function call, may be call to static predicate
7068 when N_Function_Call =>
7069 if Is_Entity_Name (Name (Exp)) then
7071 Ent : constant Entity_Id := Entity (Name (Exp));
7073 if Is_Predicate_Function (Ent)
7075 Is_Predicate_Function_M (Ent)
7077 return Stat_Pred (Etype (First_Formal (Ent)));
7082 -- Other function call cases are non-static
7086 -- Qualified expression, dig out the expression
7088 when N_Qualified_Expression =>
7089 return Get_RList (Expression (Exp));
7094 return (Get_RList (Left_Opnd (Exp))
7095 and not Get_RList (Right_Opnd (Exp)))
7096 or (Get_RList (Right_Opnd (Exp))
7097 and not Get_RList (Left_Opnd (Exp)));
7099 -- Any other node type is non-static
7110 function Hi_Val (N : Node_Id) return Uint is
7112 if Is_Static_Expression (N) then
7113 return Expr_Value (N);
7115 pragma Assert (Nkind (N) = N_Range);
7116 return Expr_Value (High_Bound (N));
7124 function Is_False (R : RList) return Boolean is
7126 return R'Length = 0;
7133 function Is_True (R : RList) return Boolean is
7136 and then R (R'First).Lo = BLo
7137 and then R (R'First).Hi = BHi;
7144 function Is_Type_Ref (N : Node_Id) return Boolean is
7146 return Nkind (N) = N_Identifier and then Chars (N) = Nam;
7153 function Lo_Val (N : Node_Id) return Uint is
7155 if Is_Static_Expression (N) then
7156 return Expr_Value (N);
7158 pragma Assert (Nkind (N) = N_Range);
7159 return Expr_Value (Low_Bound (N));
7163 ------------------------
7164 -- Membership_Entries --
7165 ------------------------
7167 function Membership_Entries (N : Node_Id) return RList is
7169 if No (Next (N)) then
7170 return Membership_Entry (N);
7172 return Membership_Entry (N) or Membership_Entries (Next (N));
7174 end Membership_Entries;
7176 ----------------------
7177 -- Membership_Entry --
7178 ----------------------
7180 function Membership_Entry (N : Node_Id) return RList is
7188 if Nkind (N) = N_Range then
7189 if not Is_Static_Expression (Low_Bound (N))
7191 not Is_Static_Expression (High_Bound (N))
7195 SLo := Expr_Value (Low_Bound (N));
7196 SHi := Expr_Value (High_Bound (N));
7197 return RList'(1 => REnt'(SLo, SHi));
7200 -- Static expression case
7202 elsif Is_Static_Expression (N) then
7203 Val := Expr_Value (N);
7204 return RList'(1 => REnt'(Val, Val));
7206 -- Identifier (other than static expression) case
7208 else pragma Assert (Nkind (N) = N_Identifier);
7212 if Is_Type (Entity (N)) then
7214 -- If type has predicates, process them
7216 if Has_Predicates (Entity (N)) then
7217 return Stat_Pred (Entity (N));
7219 -- For static subtype without predicates, get range
7221 elsif Is_Static_Subtype (Entity (N)) then
7222 SLo := Expr_Value (Type_Low_Bound (Entity (N)));
7223 SHi := Expr_Value (Type_High_Bound (Entity (N)));
7224 return RList'(1 => REnt'(SLo, SHi));
7226 -- Any other type makes us non-static
7232 -- Any other kind of identifier in predicate (e.g. a non-static
7233 -- expression value) means this is not a static predicate.
7239 end Membership_Entry;
7245 function Stat_Pred (Typ : Entity_Id) return RList is
7247 -- Not static if type does not have static predicates
7249 if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then
7253 -- Otherwise we convert the predicate list to a range list
7256 Result : RList (1 .. List_Length (Static_Predicate (Typ)));
7260 P := First (Static_Predicate (Typ));
7261 for J in Result'Range loop
7262 Result (J) := REnt'(Lo_Val (P), Hi_Val (P));
7270 -- Start of processing for Build_Static_Predicate
7273 -- Now analyze the expression to see if it is a static predicate
7276 Ranges : constant RList := Get_RList (Expr);
7277 -- Range list from expression if it is static
7282 -- Convert range list into a form for the static predicate. In the
7283 -- Ranges array, we just have raw ranges, these must be converted
7284 -- to properly typed and analyzed static expressions or range nodes.
7286 -- Note: here we limit ranges to the ranges of the subtype, so that
7287 -- a predicate is always false for values outside the subtype. That
7288 -- seems fine, such values are invalid anyway, and considering them
7289 -- to fail the predicate seems allowed and friendly, and furthermore
7290 -- simplifies processing for case statements and loops.
7294 for J in Ranges'Range loop
7296 Lo : Uint := Ranges (J).Lo;
7297 Hi : Uint := Ranges (J).Hi;
7300 -- Ignore completely out of range entry
7302 if Hi < TLo or else Lo > THi then
7305 -- Otherwise process entry
7308 -- Adjust out of range value to subtype range
7318 -- Convert range into required form
7320 Append_To (Plist, Build_Range (Lo, Hi));
7325 -- Processing was successful and all entries were static, so now we
7326 -- can store the result as the predicate list.
7328 Set_Static_Predicate (Typ, Plist);
7330 -- The processing for static predicates put the expression into
7331 -- canonical form as a series of ranges. It also eliminated
7332 -- duplicates and collapsed and combined ranges. We might as well
7333 -- replace the alternatives list of the right operand of the
7334 -- membership test with the static predicate list, which will
7335 -- usually be more efficient.
7338 New_Alts : constant List_Id := New_List;
7343 Old_Node := First (Plist);
7344 while Present (Old_Node) loop
7345 New_Node := New_Copy (Old_Node);
7347 if Nkind (New_Node) = N_Range then
7348 Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node)));
7349 Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
7352 Append_To (New_Alts, New_Node);
7356 -- If empty list, replace by False
7358 if Is_Empty_List (New_Alts) then
7359 Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc));
7361 -- Else replace by set membership test
7366 Left_Opnd => Make_Identifier (Loc, Nam),
7367 Right_Opnd => Empty,
7368 Alternatives => New_Alts));
7370 -- Resolve new expression in function context
7372 Install_Formals (Predicate_Function (Typ));
7373 Push_Scope (Predicate_Function (Typ));
7374 Analyze_And_Resolve (Expr, Standard_Boolean);
7380 -- If non-static, return doing nothing
7385 end Build_Static_Predicate;
7387 -----------------------------------------
7388 -- Check_Aspect_At_End_Of_Declarations --
7389 -----------------------------------------
7391 procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is
7392 Ent : constant Entity_Id := Entity (ASN);
7393 Ident : constant Node_Id := Identifier (ASN);
7394 A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
7396 End_Decl_Expr : constant Node_Id := Entity (Ident);
7397 -- Expression to be analyzed at end of declarations
7399 Freeze_Expr : constant Node_Id := Expression (ASN);
7400 -- Expression from call to Check_Aspect_At_Freeze_Point
7402 T : constant Entity_Id := Etype (Freeze_Expr);
7403 -- Type required for preanalyze call
7406 -- Set False if error
7408 -- On entry to this procedure, Entity (Ident) contains a copy of the
7409 -- original expression from the aspect, saved for this purpose, and
7410 -- but Expression (Ident) is a preanalyzed copy of the expression,
7411 -- preanalyzed just after the freeze point.
7413 procedure Check_Overloaded_Name;
7414 -- For aspects whose expression is simply a name, this routine checks if
7415 -- the name is overloaded or not. If so, it verifies there is an
7416 -- interpretation that matches the entity obtained at the freeze point,
7417 -- otherwise the compiler complains.
7419 ---------------------------
7420 -- Check_Overloaded_Name --
7421 ---------------------------
7423 procedure Check_Overloaded_Name is
7425 if not Is_Overloaded (End_Decl_Expr) then
7426 Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
7432 Index : Interp_Index;
7436 Get_First_Interp (End_Decl_Expr, Index, It);
7437 while Present (It.Typ) loop
7438 if It.Nam = Entity (Freeze_Expr) then
7443 Get_Next_Interp (Index, It);
7447 end Check_Overloaded_Name;
7449 -- Start of processing for Check_Aspect_At_End_Of_Declarations
7452 -- Case of aspects Dimension, Dimension_System and Synchronization
7454 if A_Id = Aspect_Synchronization then
7457 -- Case of stream attributes, just have to compare entities. However,
7458 -- the expression is just a name (possibly overloaded), and there may
7459 -- be stream operations declared for unrelated types, so we just need
7460 -- to verify that one of these interpretations is the one available at
7461 -- at the freeze point.
7463 elsif A_Id = Aspect_Input or else
7464 A_Id = Aspect_Output or else
7465 A_Id = Aspect_Read or else
7468 Analyze (End_Decl_Expr);
7469 Check_Overloaded_Name;
7471 elsif A_Id = Aspect_Variable_Indexing or else
7472 A_Id = Aspect_Constant_Indexing or else
7473 A_Id = Aspect_Default_Iterator or else
7474 A_Id = Aspect_Iterator_Element
7476 -- Make type unfrozen before analysis, to prevent spurious errors
7477 -- about late attributes.
7479 Set_Is_Frozen (Ent, False);
7480 Analyze (End_Decl_Expr);
7481 Set_Is_Frozen (Ent, True);
7483 -- If the end of declarations comes before any other freeze
7484 -- point, the Freeze_Expr is not analyzed: no check needed.
7486 if Analyzed (Freeze_Expr) and then not In_Instance then
7487 Check_Overloaded_Name;
7495 -- In a generic context the aspect expressions have not been
7496 -- preanalyzed, so do it now. There are no conformance checks
7497 -- to perform in this case.
7500 Check_Aspect_At_Freeze_Point (ASN);
7503 -- The default values attributes may be defined in the private part,
7504 -- and the analysis of the expression may take place when only the
7505 -- partial view is visible. The expression must be scalar, so use
7506 -- the full view to resolve.
7508 elsif (A_Id = Aspect_Default_Value
7510 A_Id = Aspect_Default_Component_Value)
7511 and then Is_Private_Type (T)
7513 Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T));
7515 Preanalyze_Spec_Expression (End_Decl_Expr, T);
7518 Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr);
7521 -- Output error message if error
7525 ("visibility of aspect for& changes after freeze point",
7528 ("info: & is frozen here, aspects evaluated at this point??",
7529 Freeze_Node (Ent), Ent);
7531 end Check_Aspect_At_End_Of_Declarations;
7533 ----------------------------------
7534 -- Check_Aspect_At_Freeze_Point --
7535 ----------------------------------
7537 procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is
7538 Ident : constant Node_Id := Identifier (ASN);
7539 -- Identifier (use Entity field to save expression)
7541 A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
7543 T : Entity_Id := Empty;
7544 -- Type required for preanalyze call
7547 -- On entry to this procedure, Entity (Ident) contains a copy of the
7548 -- original expression from the aspect, saved for this purpose.
7550 -- On exit from this procedure Entity (Ident) is unchanged, still
7551 -- containing that copy, but Expression (Ident) is a preanalyzed copy
7552 -- of the expression, preanalyzed just after the freeze point.
7554 -- Make a copy of the expression to be preanalyzed
7556 Set_Expression (ASN, New_Copy_Tree (Entity (Ident)));
7558 -- Find type for preanalyze call
7562 -- No_Aspect should be impossible
7565 raise Program_Error;
7567 -- Aspects taking an optional boolean argument
7569 when Boolean_Aspects |
7570 Library_Unit_Aspects =>
7572 T := Standard_Boolean;
7574 -- Aspects corresponding to attribute definition clauses
7576 when Aspect_Address =>
7577 T := RTE (RE_Address);
7579 when Aspect_Attach_Handler =>
7580 T := RTE (RE_Interrupt_ID);
7582 when Aspect_Bit_Order | Aspect_Scalar_Storage_Order =>
7583 T := RTE (RE_Bit_Order);
7585 when Aspect_Convention =>
7589 T := RTE (RE_CPU_Range);
7591 -- Default_Component_Value is resolved with the component type
7593 when Aspect_Default_Component_Value =>
7594 T := Component_Type (Entity (ASN));
7596 -- Default_Value is resolved with the type entity in question
7598 when Aspect_Default_Value =>
7601 -- Depends is a delayed aspect because it mentiones names first
7602 -- introduced by aspect Global which is already delayed. There is
7603 -- no action to be taken with respect to the aspect itself as the
7604 -- analysis is done by the corresponding pragma.
7606 when Aspect_Depends =>
7609 when Aspect_Dispatching_Domain =>
7610 T := RTE (RE_Dispatching_Domain);
7612 when Aspect_External_Tag =>
7613 T := Standard_String;
7615 when Aspect_External_Name =>
7616 T := Standard_String;
7618 -- Global is a delayed aspect because it may reference names that
7619 -- have not been declared yet. There is no action to be taken with
7620 -- respect to the aspect itself as the reference checking is done
7621 -- on the corresponding pragma.
7623 when Aspect_Global =>
7626 when Aspect_Link_Name =>
7627 T := Standard_String;
7629 when Aspect_Priority | Aspect_Interrupt_Priority =>
7630 T := Standard_Integer;
7632 when Aspect_Relative_Deadline =>
7633 T := RTE (RE_Time_Span);
7635 when Aspect_Small =>
7636 T := Universal_Real;
7638 -- For a simple storage pool, we have to retrieve the type of the
7639 -- pool object associated with the aspect's corresponding attribute
7640 -- definition clause.
7642 when Aspect_Simple_Storage_Pool =>
7643 T := Etype (Expression (Aspect_Rep_Item (ASN)));
7645 when Aspect_Storage_Pool =>
7646 T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
7648 when Aspect_Alignment |
7649 Aspect_Component_Size |
7650 Aspect_Machine_Radix |
7651 Aspect_Object_Size |
7653 Aspect_Storage_Size |
7654 Aspect_Stream_Size |
7655 Aspect_Value_Size =>
7658 when Aspect_Synchronization =>
7661 -- Special case, the expression of these aspects is just an entity
7662 -- that does not need any resolution, so just analyze.
7671 Analyze (Expression (ASN));
7674 -- Same for Iterator aspects, where the expression is a function
7675 -- name. Legality rules are checked separately.
7677 when Aspect_Constant_Indexing |
7678 Aspect_Default_Iterator |
7679 Aspect_Iterator_Element |
7680 Aspect_Variable_Indexing =>
7681 Analyze (Expression (ASN));
7684 -- Invariant/Predicate take boolean expressions
7686 when Aspect_Dynamic_Predicate |
7689 Aspect_Static_Predicate |
7690 Aspect_Type_Invariant =>
7691 T := Standard_Boolean;
7693 -- Here is the list of aspects that don't require delay analysis
7695 when Aspect_Abstract_State |
7696 Aspect_Contract_Cases |
7698 Aspect_Dimension_System |
7699 Aspect_Implicit_Dereference |
7701 Aspect_Postcondition |
7703 Aspect_Precondition |
7704 Aspect_Refined_Depends |
7705 Aspect_Refined_Global |
7706 Aspect_Refined_Post |
7707 Aspect_Refined_Pre |
7708 Aspect_Refined_State |
7711 raise Program_Error;
7715 -- Do the preanalyze call
7717 Preanalyze_Spec_Expression (Expression (ASN), T);
7718 end Check_Aspect_At_Freeze_Point;
7720 -----------------------------------
7721 -- Check_Constant_Address_Clause --
7722 -----------------------------------
7724 procedure Check_Constant_Address_Clause
7728 procedure Check_At_Constant_Address (Nod : Node_Id);
7729 -- Checks that the given node N represents a name whose 'Address is
7730 -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the
7731 -- address value is the same at the point of declaration of U_Ent and at
7732 -- the time of elaboration of the address clause.
7734 procedure Check_Expr_Constants (Nod : Node_Id);
7735 -- Checks that Nod meets the requirements for a constant address clause
7736 -- in the sense of the enclosing procedure.
7738 procedure Check_List_Constants (Lst : List_Id);
7739 -- Check that all elements of list Lst meet the requirements for a
7740 -- constant address clause in the sense of the enclosing procedure.
7742 -------------------------------
7743 -- Check_At_Constant_Address --
7744 -------------------------------
7746 procedure Check_At_Constant_Address (Nod : Node_Id) is
7748 if Is_Entity_Name (Nod) then
7749 if Present (Address_Clause (Entity ((Nod)))) then
7751 ("invalid address clause for initialized object &!",
7754 ("address for& cannot" &
7755 " depend on another address clause! (RM 13.1(22))!",
7758 elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
7759 and then Sloc (U_Ent) < Sloc (Entity (Nod))
7762 ("invalid address clause for initialized object &!",
7764 Error_Msg_Node_2 := U_Ent;
7766 ("\& must be defined before & (RM 13.1(22))!",
7770 elsif Nkind (Nod) = N_Selected_Component then
7772 T : constant Entity_Id := Etype (Prefix (Nod));
7775 if (Is_Record_Type (T)
7776 and then Has_Discriminants (T))
7779 and then Is_Record_Type (Designated_Type (T))
7780 and then Has_Discriminants (Designated_Type (T)))
7783 ("invalid address clause for initialized object &!",
7786 ("\address cannot depend on component" &
7787 " of discriminated record (RM 13.1(22))!",
7790 Check_At_Constant_Address (Prefix (Nod));
7794 elsif Nkind (Nod) = N_Indexed_Component then
7795 Check_At_Constant_Address (Prefix (Nod));
7796 Check_List_Constants (Expressions (Nod));
7799 Check_Expr_Constants (Nod);
7801 end Check_At_Constant_Address;
7803 --------------------------
7804 -- Check_Expr_Constants --
7805 --------------------------
7807 procedure Check_Expr_Constants (Nod : Node_Id) is
7808 Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
7809 Ent : Entity_Id := Empty;
7812 if Nkind (Nod) in N_Has_Etype
7813 and then Etype (Nod) = Any_Type
7819 when N_Empty | N_Error =>
7822 when N_Identifier | N_Expanded_Name =>
7823 Ent := Entity (Nod);
7825 -- We need to look at the original node if it is different
7826 -- from the node, since we may have rewritten things and
7827 -- substituted an identifier representing the rewrite.
7829 if Original_Node (Nod) /= Nod then
7830 Check_Expr_Constants (Original_Node (Nod));
7832 -- If the node is an object declaration without initial
7833 -- value, some code has been expanded, and the expression
7834 -- is not constant, even if the constituents might be
7835 -- acceptable, as in A'Address + offset.
7837 if Ekind (Ent) = E_Variable
7839 Nkind (Declaration_Node (Ent)) = N_Object_Declaration
7841 No (Expression (Declaration_Node (Ent)))
7844 ("invalid address clause for initialized object &!",
7847 -- If entity is constant, it may be the result of expanding
7848 -- a check. We must verify that its declaration appears
7849 -- before the object in question, else we also reject the
7852 elsif Ekind (Ent) = E_Constant
7853 and then In_Same_Source_Unit (Ent, U_Ent)
7854 and then Sloc (Ent) > Loc_U_Ent
7857 ("invalid address clause for initialized object &!",
7864 -- Otherwise look at the identifier and see if it is OK
7866 if Ekind_In (Ent, E_Named_Integer, E_Named_Real)
7867 or else Is_Type (Ent)
7872 Ekind (Ent) = E_Constant
7874 Ekind (Ent) = E_In_Parameter
7876 -- This is the case where we must have Ent defined before
7877 -- U_Ent. Clearly if they are in different units this
7878 -- requirement is met since the unit containing Ent is
7879 -- already processed.
7881 if not In_Same_Source_Unit (Ent, U_Ent) then
7884 -- Otherwise location of Ent must be before the location
7885 -- of U_Ent, that's what prior defined means.
7887 elsif Sloc (Ent) < Loc_U_Ent then
7892 ("invalid address clause for initialized object &!",
7894 Error_Msg_Node_2 := U_Ent;
7896 ("\& must be defined before & (RM 13.1(22))!",
7900 elsif Nkind (Original_Node (Nod)) = N_Function_Call then
7901 Check_Expr_Constants (Original_Node (Nod));
7905 ("invalid address clause for initialized object &!",
7908 if Comes_From_Source (Ent) then
7910 ("\reference to variable& not allowed"
7911 & " (RM 13.1(22))!", Nod, Ent);
7914 ("non-static expression not allowed"
7915 & " (RM 13.1(22))!", Nod);
7919 when N_Integer_Literal =>
7921 -- If this is a rewritten unchecked conversion, in a system
7922 -- where Address is an integer type, always use the base type
7923 -- for a literal value. This is user-friendly and prevents
7924 -- order-of-elaboration issues with instances of unchecked
7927 if Nkind (Original_Node (Nod)) = N_Function_Call then
7928 Set_Etype (Nod, Base_Type (Etype (Nod)));
7931 when N_Real_Literal |
7933 N_Character_Literal =>
7937 Check_Expr_Constants (Low_Bound (Nod));
7938 Check_Expr_Constants (High_Bound (Nod));
7940 when N_Explicit_Dereference =>
7941 Check_Expr_Constants (Prefix (Nod));
7943 when N_Indexed_Component =>
7944 Check_Expr_Constants (Prefix (Nod));
7945 Check_List_Constants (Expressions (Nod));
7948 Check_Expr_Constants (Prefix (Nod));
7949 Check_Expr_Constants (Discrete_Range (Nod));
7951 when N_Selected_Component =>
7952 Check_Expr_Constants (Prefix (Nod));
7954 when N_Attribute_Reference =>
7955 if Nam_In (Attribute_Name (Nod), Name_Address,
7957 Name_Unchecked_Access,
7958 Name_Unrestricted_Access)
7960 Check_At_Constant_Address (Prefix (Nod));
7963 Check_Expr_Constants (Prefix (Nod));
7964 Check_List_Constants (Expressions (Nod));
7968 Check_List_Constants (Component_Associations (Nod));
7969 Check_List_Constants (Expressions (Nod));
7971 when N_Component_Association =>
7972 Check_Expr_Constants (Expression (Nod));
7974 when N_Extension_Aggregate =>
7975 Check_Expr_Constants (Ancestor_Part (Nod));
7976 Check_List_Constants (Component_Associations (Nod));
7977 Check_List_Constants (Expressions (Nod));
7982 when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
7983 Check_Expr_Constants (Left_Opnd (Nod));
7984 Check_Expr_Constants (Right_Opnd (Nod));
7987 Check_Expr_Constants (Right_Opnd (Nod));
7989 when N_Type_Conversion |
7990 N_Qualified_Expression |
7992 N_Unchecked_Type_Conversion =>
7993 Check_Expr_Constants (Expression (Nod));
7995 when N_Function_Call =>
7996 if not Is_Pure (Entity (Name (Nod))) then
7998 ("invalid address clause for initialized object &!",
8002 ("\function & is not pure (RM 13.1(22))!",
8003 Nod, Entity (Name (Nod)));
8006 Check_List_Constants (Parameter_Associations (Nod));
8009 when N_Parameter_Association =>
8010 Check_Expr_Constants (Explicit_Actual_Parameter (Nod));
8014 ("invalid address clause for initialized object &!",
8017 ("\must be constant defined before& (RM 13.1(22))!",
8020 end Check_Expr_Constants;
8022 --------------------------
8023 -- Check_List_Constants --
8024 --------------------------
8026 procedure Check_List_Constants (Lst : List_Id) is
8030 if Present (Lst) then
8031 Nod1 := First (Lst);
8032 while Present (Nod1) loop
8033 Check_Expr_Constants (Nod1);
8037 end Check_List_Constants;
8039 -- Start of processing for Check_Constant_Address_Clause
8042 -- If rep_clauses are to be ignored, no need for legality checks. In
8043 -- particular, no need to pester user about rep clauses that violate
8044 -- the rule on constant addresses, given that these clauses will be
8045 -- removed by Freeze before they reach the back end.
8047 if not Ignore_Rep_Clauses then
8048 Check_Expr_Constants (Expr);
8050 end Check_Constant_Address_Clause;
8052 ----------------------------------------
8053 -- Check_Record_Representation_Clause --
8054 ----------------------------------------
8056 procedure Check_Record_Representation_Clause (N : Node_Id) is
8057 Loc : constant Source_Ptr := Sloc (N);
8058 Ident : constant Node_Id := Identifier (N);
8059 Rectype : Entity_Id;
8064 Hbit : Uint := Uint_0;
8068 Max_Bit_So_Far : Uint;
8069 -- Records the maximum bit position so far. If all field positions
8070 -- are monotonically increasing, then we can skip the circuit for
8071 -- checking for overlap, since no overlap is possible.
8073 Tagged_Parent : Entity_Id := Empty;
8074 -- This is set in the case of a derived tagged type for which we have
8075 -- Is_Fully_Repped_Tagged_Type True (indicating that all components are
8076 -- positioned by record representation clauses). In this case we must
8077 -- check for overlap between components of this tagged type, and the
8078 -- components of its parent. Tagged_Parent will point to this parent
8079 -- type. For all other cases Tagged_Parent is left set to Empty.
8081 Parent_Last_Bit : Uint;
8082 -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
8083 -- last bit position for any field in the parent type. We only need to
8084 -- check overlap for fields starting below this point.
8086 Overlap_Check_Required : Boolean;
8087 -- Used to keep track of whether or not an overlap check is required
8089 Overlap_Detected : Boolean := False;
8090 -- Set True if an overlap is detected
8092 Ccount : Natural := 0;
8093 -- Number of component clauses in record rep clause
8095 procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
8096 -- Given two entities for record components or discriminants, checks
8097 -- if they have overlapping component clauses and issues errors if so.
8099 procedure Find_Component;
8100 -- Finds component entity corresponding to current component clause (in
8101 -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin
8102 -- start/stop bits for the field. If there is no matching component or
8103 -- if the matching component does not have a component clause, then
8104 -- that's an error and Comp is set to Empty, but no error message is
8105 -- issued, since the message was already given. Comp is also set to
8106 -- Empty if the current "component clause" is in fact a pragma.
8108 -----------------------------
8109 -- Check_Component_Overlap --
8110 -----------------------------
8112 procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is
8113 CC1 : constant Node_Id := Component_Clause (C1_Ent);
8114 CC2 : constant Node_Id := Component_Clause (C2_Ent);
8117 if Present (CC1) and then Present (CC2) then
8119 -- Exclude odd case where we have two tag components in the same
8120 -- record, both at location zero. This seems a bit strange, but
8121 -- it seems to happen in some circumstances, perhaps on an error.
8123 if Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then
8127 -- Here we check if the two fields overlap
8130 S1 : constant Uint := Component_Bit_Offset (C1_Ent);
8131 S2 : constant Uint := Component_Bit_Offset (C2_Ent);
8132 E1 : constant Uint := S1 + Esize (C1_Ent);
8133 E2 : constant Uint := S2 + Esize (C2_Ent);
8136 if E2 <= S1 or else E1 <= S2 then
8139 Error_Msg_Node_2 := Component_Name (CC2);
8140 Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
8141 Error_Msg_Node_1 := Component_Name (CC1);
8143 ("component& overlaps & #", Component_Name (CC1));
8144 Overlap_Detected := True;
8148 end Check_Component_Overlap;
8150 --------------------
8151 -- Find_Component --
8152 --------------------
8154 procedure Find_Component is
8156 procedure Search_Component (R : Entity_Id);
8157 -- Search components of R for a match. If found, Comp is set
8159 ----------------------
8160 -- Search_Component --
8161 ----------------------
8163 procedure Search_Component (R : Entity_Id) is
8165 Comp := First_Component_Or_Discriminant (R);
8166 while Present (Comp) loop
8168 -- Ignore error of attribute name for component name (we
8169 -- already gave an error message for this, so no need to
8172 if Nkind (Component_Name (CC)) = N_Attribute_Reference then
8175 exit when Chars (Comp) = Chars (Component_Name (CC));
8178 Next_Component_Or_Discriminant (Comp);
8180 end Search_Component;
8182 -- Start of processing for Find_Component
8185 -- Return with Comp set to Empty if we have a pragma
8187 if Nkind (CC) = N_Pragma then
8192 -- Search current record for matching component
8194 Search_Component (Rectype);
8196 -- If not found, maybe component of base type discriminant that is
8197 -- absent from statically constrained first subtype.
8200 Search_Component (Base_Type (Rectype));
8203 -- If no component, or the component does not reference the component
8204 -- clause in question, then there was some previous error for which
8205 -- we already gave a message, so just return with Comp Empty.
8207 if No (Comp) or else Component_Clause (Comp) /= CC then
8208 Check_Error_Detected;
8211 -- Normal case where we have a component clause
8214 Fbit := Component_Bit_Offset (Comp);
8215 Lbit := Fbit + Esize (Comp) - 1;
8219 -- Start of processing for Check_Record_Representation_Clause
8223 Rectype := Entity (Ident);
8225 if Rectype = Any_Type then
8228 Rectype := Underlying_Type (Rectype);
8231 -- See if we have a fully repped derived tagged type
8234 PS : constant Entity_Id := Parent_Subtype (Rectype);
8237 if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
8238 Tagged_Parent := PS;
8240 -- Find maximum bit of any component of the parent type
8242 Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
8243 Pcomp := First_Entity (Tagged_Parent);
8244 while Present (Pcomp) loop
8245 if Ekind_In (Pcomp, E_Discriminant, E_Component) then
8246 if Component_Bit_Offset (Pcomp) /= No_Uint
8247 and then Known_Static_Esize (Pcomp)
8252 Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
8255 Next_Entity (Pcomp);
8261 -- All done if no component clauses
8263 CC := First (Component_Clauses (N));
8269 -- If a tag is present, then create a component clause that places it
8270 -- at the start of the record (otherwise gigi may place it after other
8271 -- fields that have rep clauses).
8273 Fent := First_Entity (Rectype);
8275 if Nkind (Fent) = N_Defining_Identifier
8276 and then Chars (Fent) = Name_uTag
8278 Set_Component_Bit_Offset (Fent, Uint_0);
8279 Set_Normalized_Position (Fent, Uint_0);
8280 Set_Normalized_First_Bit (Fent, Uint_0);
8281 Set_Normalized_Position_Max (Fent, Uint_0);
8282 Init_Esize (Fent, System_Address_Size);
8284 Set_Component_Clause (Fent,
8285 Make_Component_Clause (Loc,
8286 Component_Name => Make_Identifier (Loc, Name_uTag),
8288 Position => Make_Integer_Literal (Loc, Uint_0),
8289 First_Bit => Make_Integer_Literal (Loc, Uint_0),
8291 Make_Integer_Literal (Loc,
8292 UI_From_Int (System_Address_Size))));
8294 Ccount := Ccount + 1;
8297 Max_Bit_So_Far := Uint_Minus_1;
8298 Overlap_Check_Required := False;
8300 -- Process the component clauses
8302 while Present (CC) loop
8305 if Present (Comp) then
8306 Ccount := Ccount + 1;
8308 -- We need a full overlap check if record positions non-monotonic
8310 if Fbit <= Max_Bit_So_Far then
8311 Overlap_Check_Required := True;
8314 Max_Bit_So_Far := Lbit;
8316 -- Check bit position out of range of specified size
8318 if Has_Size_Clause (Rectype)
8319 and then RM_Size (Rectype) <= Lbit
8322 ("bit number out of range of specified size",
8325 -- Check for overlap with tag component
8328 if Is_Tagged_Type (Rectype)
8329 and then Fbit < System_Address_Size
8332 ("component overlaps tag field of&",
8333 Component_Name (CC), Rectype);
8334 Overlap_Detected := True;
8342 -- Check parent overlap if component might overlap parent field
8344 if Present (Tagged_Parent) and then Fbit <= Parent_Last_Bit then
8345 Pcomp := First_Component_Or_Discriminant (Tagged_Parent);
8346 while Present (Pcomp) loop
8347 if not Is_Tag (Pcomp)
8348 and then Chars (Pcomp) /= Name_uParent
8350 Check_Component_Overlap (Comp, Pcomp);
8353 Next_Component_Or_Discriminant (Pcomp);
8361 -- Now that we have processed all the component clauses, check for
8362 -- overlap. We have to leave this till last, since the components can
8363 -- appear in any arbitrary order in the representation clause.
8365 -- We do not need this check if all specified ranges were monotonic,
8366 -- as recorded by Overlap_Check_Required being False at this stage.
8368 -- This first section checks if there are any overlapping entries at
8369 -- all. It does this by sorting all entries and then seeing if there are
8370 -- any overlaps. If there are none, then that is decisive, but if there
8371 -- are overlaps, they may still be OK (they may result from fields in
8372 -- different variants).
8374 if Overlap_Check_Required then
8375 Overlap_Check1 : declare
8377 OC_Fbit : array (0 .. Ccount) of Uint;
8378 -- First-bit values for component clauses, the value is the offset
8379 -- of the first bit of the field from start of record. The zero
8380 -- entry is for use in sorting.
8382 OC_Lbit : array (0 .. Ccount) of Uint;
8383 -- Last-bit values for component clauses, the value is the offset
8384 -- of the last bit of the field from start of record. The zero
8385 -- entry is for use in sorting.
8387 OC_Count : Natural := 0;
8388 -- Count of entries in OC_Fbit and OC_Lbit
8390 function OC_Lt (Op1, Op2 : Natural) return Boolean;
8391 -- Compare routine for Sort
8393 procedure OC_Move (From : Natural; To : Natural);
8394 -- Move routine for Sort
8396 package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt);
8402 function OC_Lt (Op1, Op2 : Natural) return Boolean is
8404 return OC_Fbit (Op1) < OC_Fbit (Op2);
8411 procedure OC_Move (From : Natural; To : Natural) is
8413 OC_Fbit (To) := OC_Fbit (From);
8414 OC_Lbit (To) := OC_Lbit (From);
8417 -- Start of processing for Overlap_Check
8420 CC := First (Component_Clauses (N));
8421 while Present (CC) loop
8423 -- Exclude component clause already marked in error
8425 if not Error_Posted (CC) then
8428 if Present (Comp) then
8429 OC_Count := OC_Count + 1;
8430 OC_Fbit (OC_Count) := Fbit;
8431 OC_Lbit (OC_Count) := Lbit;
8438 Sorting.Sort (OC_Count);
8440 Overlap_Check_Required := False;
8441 for J in 1 .. OC_Count - 1 loop
8442 if OC_Lbit (J) >= OC_Fbit (J + 1) then
8443 Overlap_Check_Required := True;
8450 -- If Overlap_Check_Required is still True, then we have to do the full
8451 -- scale overlap check, since we have at least two fields that do
8452 -- overlap, and we need to know if that is OK since they are in
8453 -- different variant, or whether we have a definite problem.
8455 if Overlap_Check_Required then
8456 Overlap_Check2 : declare
8457 C1_Ent, C2_Ent : Entity_Id;
8458 -- Entities of components being checked for overlap
8461 -- Component_List node whose Component_Items are being checked
8464 -- Component declaration for component being checked
8467 C1_Ent := First_Entity (Base_Type (Rectype));
8469 -- Loop through all components in record. For each component check
8470 -- for overlap with any of the preceding elements on the component
8471 -- list containing the component and also, if the component is in
8472 -- a variant, check against components outside the case structure.
8473 -- This latter test is repeated recursively up the variant tree.
8475 Main_Component_Loop : while Present (C1_Ent) loop
8476 if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then
8477 goto Continue_Main_Component_Loop;
8480 -- Skip overlap check if entity has no declaration node. This
8481 -- happens with discriminants in constrained derived types.
8482 -- Possibly we are missing some checks as a result, but that
8483 -- does not seem terribly serious.
8485 if No (Declaration_Node (C1_Ent)) then
8486 goto Continue_Main_Component_Loop;
8489 Clist := Parent (List_Containing (Declaration_Node (C1_Ent)));
8491 -- Loop through component lists that need checking. Check the
8492 -- current component list and all lists in variants above us.
8494 Component_List_Loop : loop
8496 -- If derived type definition, go to full declaration
8497 -- If at outer level, check discriminants if there are any.
8499 if Nkind (Clist) = N_Derived_Type_Definition then
8500 Clist := Parent (Clist);
8503 -- Outer level of record definition, check discriminants
8505 if Nkind_In (Clist, N_Full_Type_Declaration,
8506 N_Private_Type_Declaration)
8508 if Has_Discriminants (Defining_Identifier (Clist)) then
8510 First_Discriminant (Defining_Identifier (Clist));
8511 while Present (C2_Ent) loop
8512 exit when C1_Ent = C2_Ent;
8513 Check_Component_Overlap (C1_Ent, C2_Ent);
8514 Next_Discriminant (C2_Ent);
8518 -- Record extension case
8520 elsif Nkind (Clist) = N_Derived_Type_Definition then
8523 -- Otherwise check one component list
8526 Citem := First (Component_Items (Clist));
8527 while Present (Citem) loop
8528 if Nkind (Citem) = N_Component_Declaration then
8529 C2_Ent := Defining_Identifier (Citem);
8530 exit when C1_Ent = C2_Ent;
8531 Check_Component_Overlap (C1_Ent, C2_Ent);
8538 -- Check for variants above us (the parent of the Clist can
8539 -- be a variant, in which case its parent is a variant part,
8540 -- and the parent of the variant part is a component list
8541 -- whose components must all be checked against the current
8542 -- component for overlap).
8544 if Nkind (Parent (Clist)) = N_Variant then
8545 Clist := Parent (Parent (Parent (Clist)));
8547 -- Check for possible discriminant part in record, this
8548 -- is treated essentially as another level in the
8549 -- recursion. For this case the parent of the component
8550 -- list is the record definition, and its parent is the
8551 -- full type declaration containing the discriminant
8554 elsif Nkind (Parent (Clist)) = N_Record_Definition then
8555 Clist := Parent (Parent ((Clist)));
8557 -- If neither of these two cases, we are at the top of
8561 exit Component_List_Loop;
8563 end loop Component_List_Loop;
8565 <<Continue_Main_Component_Loop>>
8566 Next_Entity (C1_Ent);
8568 end loop Main_Component_Loop;
8572 -- The following circuit deals with warning on record holes (gaps). We
8573 -- skip this check if overlap was detected, since it makes sense for the
8574 -- programmer to fix this illegality before worrying about warnings.
8576 if not Overlap_Detected and Warn_On_Record_Holes then
8577 Record_Hole_Check : declare
8578 Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype));
8579 -- Full declaration of record type
8581 procedure Check_Component_List
8585 -- Check component list CL for holes. The starting bit should be
8586 -- Sbit. which is zero for the main record component list and set
8587 -- appropriately for recursive calls for variants. DS is set to
8588 -- a list of discriminant specifications to be included in the
8589 -- consideration of components. It is No_List if none to consider.
8591 --------------------------
8592 -- Check_Component_List --
8593 --------------------------
8595 procedure Check_Component_List
8603 Compl := Integer (List_Length (Component_Items (CL)));
8605 if DS /= No_List then
8606 Compl := Compl + Integer (List_Length (DS));
8610 Comps : array (Natural range 0 .. Compl) of Entity_Id;
8611 -- Gather components (zero entry is for sort routine)
8613 Ncomps : Natural := 0;
8614 -- Number of entries stored in Comps (starting at Comps (1))
8617 -- One component item or discriminant specification
8620 -- Starting bit for next component
8628 function Lt (Op1, Op2 : Natural) return Boolean;
8629 -- Compare routine for Sort
8631 procedure Move (From : Natural; To : Natural);
8632 -- Move routine for Sort
8634 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
8640 function Lt (Op1, Op2 : Natural) return Boolean is
8642 return Component_Bit_Offset (Comps (Op1))
8644 Component_Bit_Offset (Comps (Op2));
8651 procedure Move (From : Natural; To : Natural) is
8653 Comps (To) := Comps (From);
8657 -- Gather discriminants into Comp
8659 if DS /= No_List then
8660 Citem := First (DS);
8661 while Present (Citem) loop
8662 if Nkind (Citem) = N_Discriminant_Specification then
8664 Ent : constant Entity_Id :=
8665 Defining_Identifier (Citem);
8667 if Ekind (Ent) = E_Discriminant then
8668 Ncomps := Ncomps + 1;
8669 Comps (Ncomps) := Ent;
8678 -- Gather component entities into Comp
8680 Citem := First (Component_Items (CL));
8681 while Present (Citem) loop
8682 if Nkind (Citem) = N_Component_Declaration then
8683 Ncomps := Ncomps + 1;
8684 Comps (Ncomps) := Defining_Identifier (Citem);
8690 -- Now sort the component entities based on the first bit.
8691 -- Note we already know there are no overlapping components.
8693 Sorting.Sort (Ncomps);
8695 -- Loop through entries checking for holes
8698 for J in 1 .. Ncomps loop
8700 Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit;
8702 if Error_Msg_Uint_1 > 0 then
8704 ("?H?^-bit gap before component&",
8705 Component_Name (Component_Clause (CEnt)), CEnt);
8708 Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt);
8711 -- Process variant parts recursively if present
8713 if Present (Variant_Part (CL)) then
8714 Variant := First (Variants (Variant_Part (CL)));
8715 while Present (Variant) loop
8716 Check_Component_List
8717 (Component_List (Variant), Nbit, No_List);
8722 end Check_Component_List;
8724 -- Start of processing for Record_Hole_Check
8731 if Is_Tagged_Type (Rectype) then
8732 Sbit := UI_From_Int (System_Address_Size);
8737 if Nkind (Decl) = N_Full_Type_Declaration
8738 and then Nkind (Type_Definition (Decl)) = N_Record_Definition
8740 Check_Component_List
8741 (Component_List (Type_Definition (Decl)),
8743 Discriminant_Specifications (Decl));
8746 end Record_Hole_Check;
8749 -- For records that have component clauses for all components, and whose
8750 -- size is less than or equal to 32, we need to know the size in the
8751 -- front end to activate possible packed array processing where the
8752 -- component type is a record.
8754 -- At this stage Hbit + 1 represents the first unused bit from all the
8755 -- component clauses processed, so if the component clauses are
8756 -- complete, then this is the length of the record.
8758 -- For records longer than System.Storage_Unit, and for those where not
8759 -- all components have component clauses, the back end determines the
8760 -- length (it may for example be appropriate to round up the size
8761 -- to some convenient boundary, based on alignment considerations, etc).
8763 if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then
8765 -- Nothing to do if at least one component has no component clause
8767 Comp := First_Component_Or_Discriminant (Rectype);
8768 while Present (Comp) loop
8769 exit when No (Component_Clause (Comp));
8770 Next_Component_Or_Discriminant (Comp);
8773 -- If we fall out of loop, all components have component clauses
8774 -- and so we can set the size to the maximum value.
8777 Set_RM_Size (Rectype, Hbit + 1);
8780 end Check_Record_Representation_Clause;
8786 procedure Check_Size
8790 Biased : out Boolean)
8792 UT : constant Entity_Id := Underlying_Type (T);
8798 -- Reject patently improper size values.
8800 if Is_Elementary_Type (T)
8801 and then Siz > UI_From_Int (Int'Last)
8803 Error_Msg_N ("Size value too large for elementary type", N);
8805 if Nkind (Original_Node (N)) = N_Op_Expon then
8807 ("\maybe '* was meant, rather than '*'*", Original_Node (N));
8811 -- Dismiss generic types
8813 if Is_Generic_Type (T)
8815 Is_Generic_Type (UT)
8817 Is_Generic_Type (Root_Type (UT))
8821 -- Guard against previous errors
8823 elsif No (UT) or else UT = Any_Type then
8824 Check_Error_Detected;
8827 -- Check case of bit packed array
8829 elsif Is_Array_Type (UT)
8830 and then Known_Static_Component_Size (UT)
8831 and then Is_Bit_Packed_Array (UT)
8839 Asiz := Component_Size (UT);
8840 Indx := First_Index (UT);
8842 Ityp := Etype (Indx);
8844 -- If non-static bound, then we are not in the business of
8845 -- trying to check the length, and indeed an error will be
8846 -- issued elsewhere, since sizes of non-static array types
8847 -- cannot be set implicitly or explicitly.
8849 if not Is_Static_Subtype (Ityp) then
8853 -- Otherwise accumulate next dimension
8855 Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) -
8856 Expr_Value (Type_Low_Bound (Ityp)) +
8860 exit when No (Indx);
8867 Error_Msg_Uint_1 := Asiz;
8869 ("size for& too small, minimum allowed is ^", N, T);
8870 Set_Esize (T, Asiz);
8871 Set_RM_Size (T, Asiz);
8875 -- All other composite types are ignored
8877 elsif Is_Composite_Type (UT) then
8880 -- For fixed-point types, don't check minimum if type is not frozen,
8881 -- since we don't know all the characteristics of the type that can
8882 -- affect the size (e.g. a specified small) till freeze time.
8884 elsif Is_Fixed_Point_Type (UT)
8885 and then not Is_Frozen (UT)
8889 -- Cases for which a minimum check is required
8892 -- Ignore if specified size is correct for the type
8894 if Known_Esize (UT) and then Siz = Esize (UT) then
8898 -- Otherwise get minimum size
8900 M := UI_From_Int (Minimum_Size (UT));
8904 -- Size is less than minimum size, but one possibility remains
8905 -- that we can manage with the new size if we bias the type.
8907 M := UI_From_Int (Minimum_Size (UT, Biased => True));
8910 Error_Msg_Uint_1 := M;
8912 ("size for& too small, minimum allowed is ^", N, T);
8922 --------------------------
8923 -- Freeze_Entity_Checks --
8924 --------------------------
8926 procedure Freeze_Entity_Checks (N : Node_Id) is
8927 E : constant Entity_Id := Entity (N);
8929 Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity;
8930 -- True in non-generic case. Some of the processing here is skipped
8931 -- for the generic case since it is not needed. Basically in the
8932 -- generic case, we only need to do stuff that might generate error
8933 -- messages or warnings.
8935 -- Remember that we are processing a freezing entity. Required to
8936 -- ensure correct decoration of internal entities associated with
8937 -- interfaces (see New_Overloaded_Entity).
8939 Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
8941 -- For tagged types covering interfaces add internal entities that link
8942 -- the primitives of the interfaces with the primitives that cover them.
8943 -- Note: These entities were originally generated only when generating
8944 -- code because their main purpose was to provide support to initialize
8945 -- the secondary dispatch tables. They are now generated also when
8946 -- compiling with no code generation to provide ASIS the relationship
8947 -- between interface primitives and tagged type primitives. They are
8948 -- also used to locate primitives covering interfaces when processing
8949 -- generics (see Derive_Subprograms).
8951 -- This is not needed in the generic case
8953 if Ada_Version >= Ada_2005
8954 and then Non_Generic_Case
8955 and then Ekind (E) = E_Record_Type
8956 and then Is_Tagged_Type (E)
8957 and then not Is_Interface (E)
8958 and then Has_Interfaces (E)
8960 -- This would be a good common place to call the routine that checks
8961 -- overriding of interface primitives (and thus factorize calls to
8962 -- Check_Abstract_Overriding located at different contexts in the
8963 -- compiler). However, this is not possible because it causes
8964 -- spurious errors in case of late overriding.
8966 Add_Internal_Interface_Entities (E);
8971 if Ekind (E) = E_Record_Type
8972 and then Is_CPP_Class (E)
8973 and then Is_Tagged_Type (E)
8974 and then Tagged_Type_Expansion
8975 and then Expander_Active -- why? losing errors in -gnatc mode???
8977 if CPP_Num_Prims (E) = 0 then
8979 -- If the CPP type has user defined components then it must import
8980 -- primitives from C++. This is required because if the C++ class
8981 -- has no primitives then the C++ compiler does not added the _tag
8982 -- component to the type.
8984 pragma Assert (Chars (First_Entity (E)) = Name_uTag);
8986 if First_Entity (E) /= Last_Entity (E) then
8988 ("'C'P'P type must import at least one primitive from C++??",
8993 -- Check that all its primitives are abstract or imported from C++.
8994 -- Check also availability of the C++ constructor.
8997 Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
8999 Error_Reported : Boolean := False;
9003 Elmt := First_Elmt (Primitive_Operations (E));
9004 while Present (Elmt) loop
9005 Prim := Node (Elmt);
9007 if Comes_From_Source (Prim) then
9008 if Is_Abstract_Subprogram (Prim) then
9011 elsif not Is_Imported (Prim)
9012 or else Convention (Prim) /= Convention_CPP
9015 ("primitives of 'C'P'P types must be imported from C++ "
9016 & "or abstract??", Prim);
9018 elsif not Has_Constructors
9019 and then not Error_Reported
9021 Error_Msg_Name_1 := Chars (E);
9023 ("??'C'P'P constructor required for type %", Prim);
9024 Error_Reported := True;
9033 -- Check Ada derivation of CPP type
9035 if Expander_Active -- why? losing errors in -gnatc mode???
9036 and then Tagged_Type_Expansion
9037 and then Ekind (E) = E_Record_Type
9038 and then Etype (E) /= E
9039 and then Is_CPP_Class (Etype (E))
9040 and then CPP_Num_Prims (Etype (E)) > 0
9041 and then not Is_CPP_Class (E)
9042 and then not Has_CPP_Constructors (Etype (E))
9044 -- If the parent has C++ primitives but it has no constructor then
9045 -- check that all the primitives are overridden in this derivation;
9046 -- otherwise the constructor of the parent is needed to build the
9054 Elmt := First_Elmt (Primitive_Operations (E));
9055 while Present (Elmt) loop
9056 Prim := Node (Elmt);
9058 if not Is_Abstract_Subprogram (Prim)
9059 and then No (Interface_Alias (Prim))
9060 and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E
9062 Error_Msg_Name_1 := Chars (Etype (E));
9064 ("'C'P'P constructor required for parent type %", E);
9073 Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
9075 -- If we have a type with predicates, build predicate function. This
9076 -- is not needed in the generic casee
9078 if Non_Generic_Case and then Is_Type (E) and then Has_Predicates (E) then
9079 Build_Predicate_Functions (E, N);
9082 -- If type has delayed aspects, this is where we do the preanalysis at
9083 -- the freeze point, as part of the consistent visibility check. Note
9084 -- that this must be done after calling Build_Predicate_Functions or
9085 -- Build_Invariant_Procedure since these subprograms fix occurrences of
9086 -- the subtype name in the saved expression so that they will not cause
9087 -- trouble in the preanalysis.
9089 -- This is also not needed in the generic case
9092 and then Has_Delayed_Aspects (E)
9093 and then Scope (E) = Current_Scope
9095 -- Retrieve the visibility to the discriminants in order to properly
9096 -- analyze the aspects.
9098 Push_Scope_And_Install_Discriminants (E);
9104 -- Look for aspect specification entries for this entity
9106 Ritem := First_Rep_Item (E);
9107 while Present (Ritem) loop
9108 if Nkind (Ritem) = N_Aspect_Specification
9109 and then Entity (Ritem) = E
9110 and then Is_Delayed_Aspect (Ritem)
9112 Check_Aspect_At_Freeze_Point (Ritem);
9115 Next_Rep_Item (Ritem);
9119 Uninstall_Discriminants_And_Pop_Scope (E);
9122 -- For a record type, deal with variant parts. This has to be delayed
9123 -- to this point, because of the issue of statically precicated
9124 -- subtypes, which we have to ensure are frozen before checking
9125 -- choices, since we need to have the static choice list set.
9127 if Is_Record_Type (E) then
9128 Check_Variant_Part : declare
9129 D : constant Node_Id := Declaration_Node (E);
9134 Others_Present : Boolean;
9135 pragma Warnings (Off, Others_Present);
9136 -- Indicates others present, not used in this case
9138 procedure Non_Static_Choice_Error (Choice : Node_Id);
9139 -- Error routine invoked by the generic instantiation below when
9140 -- the variant part has a non static choice.
9142 procedure Process_Declarations (Variant : Node_Id);
9143 -- Processes declarations associated with a variant. We analyzed
9144 -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part),
9145 -- but we still need the recursive call to Check_Choices for any
9146 -- nested variant to get its choices properly processed. This is
9147 -- also where we expand out the choices if expansion is active.
9149 package Variant_Choices_Processing is new
9150 Generic_Check_Choices
9151 (Process_Empty_Choice => No_OP,
9152 Process_Non_Static_Choice => Non_Static_Choice_Error,
9153 Process_Associated_Node => Process_Declarations);
9154 use Variant_Choices_Processing;
9156 -----------------------------
9157 -- Non_Static_Choice_Error --
9158 -----------------------------
9160 procedure Non_Static_Choice_Error (Choice : Node_Id) is
9162 Flag_Non_Static_Expr
9163 ("choice given in variant part is not static!", Choice);
9164 end Non_Static_Choice_Error;
9166 --------------------------
9167 -- Process_Declarations --
9168 --------------------------
9170 procedure Process_Declarations (Variant : Node_Id) is
9171 CL : constant Node_Id := Component_List (Variant);
9175 -- Check for static predicate present in this variant
9177 if Has_SP_Choice (Variant) then
9179 -- Here we expand. You might expect to find this call in
9180 -- Expand_N_Variant_Part, but that is called when we first
9181 -- see the variant part, and we cannot do this expansion
9182 -- earlier than the freeze point, since for statically
9183 -- predicated subtypes, the predicate is not known till
9184 -- the freeze point.
9186 -- Furthermore, we do this expansion even if the expander
9187 -- is not active, because other semantic processing, e.g.
9188 -- for aggregates, requires the expanded list of choices.
9190 -- If the expander is not active, then we can't just clobber
9191 -- the list since it would invalidate the ASIS -gnatct tree.
9192 -- So we have to rewrite the variant part with a Rewrite
9193 -- call that replaces it with a copy and clobber the copy.
9195 if not Expander_Active then
9197 NewV : constant Node_Id := New_Copy (Variant);
9199 Set_Discrete_Choices
9200 (NewV, New_Copy_List (Discrete_Choices (Variant)));
9201 Rewrite (Variant, NewV);
9205 Expand_Static_Predicates_In_Choices (Variant);
9208 -- We don't need to worry about the declarations in the variant
9209 -- (since they were analyzed by Analyze_Choices when we first
9210 -- encountered the variant), but we do need to take care of
9211 -- expansion of any nested variants.
9213 if not Null_Present (CL) then
9214 VP := Variant_Part (CL);
9216 if Present (VP) then
9218 (VP, Variants (VP), Etype (Name (VP)), Others_Present);
9221 end Process_Declarations;
9223 -- Start of processing for Check_Variant_Part
9226 -- Find component list
9230 if Nkind (D) = N_Full_Type_Declaration then
9231 T := Type_Definition (D);
9233 if Nkind (T) = N_Record_Definition then
9234 C := Component_List (T);
9236 elsif Nkind (T) = N_Derived_Type_Definition
9237 and then Present (Record_Extension_Part (T))
9239 C := Component_List (Record_Extension_Part (T));
9243 -- Case of variant part present
9245 if Present (C) and then Present (Variant_Part (C)) then
9246 VP := Variant_Part (C);
9251 (VP, Variants (VP), Etype (Name (VP)), Others_Present);
9253 -- If the last variant does not contain the Others choice,
9254 -- replace it with an N_Others_Choice node since Gigi always
9255 -- wants an Others. Note that we do not bother to call Analyze
9256 -- on the modified variant part, since its only effect would be
9257 -- to compute the Others_Discrete_Choices node laboriously, and
9258 -- of course we already know the list of choices corresponding
9259 -- to the others choice (it's the list we're replacing!)
9261 -- We only want to do this if the expander is active, since
9262 -- we do not want to clobber the ASIS tree!
9264 if Expander_Active then
9266 Last_Var : constant Node_Id :=
9267 Last_Non_Pragma (Variants (VP));
9269 Others_Node : Node_Id;
9272 if Nkind (First (Discrete_Choices (Last_Var))) /=
9275 Others_Node := Make_Others_Choice (Sloc (Last_Var));
9276 Set_Others_Discrete_Choices
9277 (Others_Node, Discrete_Choices (Last_Var));
9278 Set_Discrete_Choices
9279 (Last_Var, New_List (Others_Node));
9284 end Check_Variant_Part;
9286 end Freeze_Entity_Checks;
9288 -------------------------
9289 -- Get_Alignment_Value --
9290 -------------------------
9292 function Get_Alignment_Value (Expr : Node_Id) return Uint is
9293 Align : constant Uint := Static_Integer (Expr);
9296 if Align = No_Uint then
9299 elsif Align <= 0 then
9300 Error_Msg_N ("alignment value must be positive", Expr);
9304 for J in Int range 0 .. 64 loop
9306 M : constant Uint := Uint_2 ** J;
9309 exit when M = Align;
9313 ("alignment value must be power of 2", Expr);
9321 end Get_Alignment_Value;
9323 -------------------------------------
9324 -- Inherit_Aspects_At_Freeze_Point --
9325 -------------------------------------
9327 procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
9329 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9330 (Rep_Item : Node_Id) return Boolean;
9331 -- This routine checks if Rep_Item is either a pragma or an aspect
9332 -- specification node whose correponding pragma (if any) is present in
9333 -- the Rep Item chain of the entity it has been specified to.
9335 --------------------------------------------------
9336 -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item --
9337 --------------------------------------------------
9339 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9340 (Rep_Item : Node_Id) return Boolean
9343 return Nkind (Rep_Item) = N_Pragma
9344 or else Present_In_Rep_Item
9345 (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
9346 end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item;
9348 -- Start of processing for Inherit_Aspects_At_Freeze_Point
9351 -- A representation item is either subtype-specific (Size and Alignment
9352 -- clauses) or type-related (all others). Subtype-specific aspects may
9353 -- differ for different subtypes of the same type (RM 13.1.8).
9355 -- A derived type inherits each type-related representation aspect of
9356 -- its parent type that was directly specified before the declaration of
9357 -- the derived type (RM 13.1.15).
9359 -- A derived subtype inherits each subtype-specific representation
9360 -- aspect of its parent subtype that was directly specified before the
9361 -- declaration of the derived type (RM 13.1.15).
9363 -- The general processing involves inheriting a representation aspect
9364 -- from a parent type whenever the first rep item (aspect specification,
9365 -- attribute definition clause, pragma) corresponding to the given
9366 -- representation aspect in the rep item chain of Typ, if any, isn't
9367 -- directly specified to Typ but to one of its parents.
9369 -- ??? Note that, for now, just a limited number of representation
9370 -- aspects have been inherited here so far. Many of them are
9371 -- still inherited in Sem_Ch3. This will be fixed soon. Here is
9372 -- a non- exhaustive list of aspects that likely also need to
9373 -- be moved to this routine: Alignment, Component_Alignment,
9374 -- Component_Size, Machine_Radix, Object_Size, Pack, Predicates,
9375 -- Preelaborable_Initialization, RM_Size and Small.
9377 if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then
9383 if not Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005, False)
9384 and then Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005)
9385 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9386 (Get_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005))
9388 Set_Is_Ada_2005_Only (Typ);
9393 if not Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012, False)
9394 and then Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012)
9395 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9396 (Get_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012))
9398 Set_Is_Ada_2012_Only (Typ);
9403 if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False)
9404 and then Has_Rep_Pragma (Typ, Name_Atomic, Name_Shared)
9405 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9406 (Get_Rep_Item (Typ, Name_Atomic, Name_Shared))
9408 Set_Is_Atomic (Typ);
9409 Set_Treat_As_Volatile (Typ);
9410 Set_Is_Volatile (Typ);
9413 -- Default_Component_Value
9415 if Is_Array_Type (Typ)
9416 and then Has_Rep_Item (Typ, Name_Default_Component_Value, False)
9417 and then Has_Rep_Item (Typ, Name_Default_Component_Value)
9419 Set_Default_Aspect_Component_Value (Typ,
9420 Default_Aspect_Component_Value
9421 (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value))));
9426 if Is_Scalar_Type (Typ)
9427 and then Has_Rep_Item (Typ, Name_Default_Value, False)
9428 and then Has_Rep_Item (Typ, Name_Default_Value)
9430 Set_Default_Aspect_Value (Typ,
9431 Default_Aspect_Value
9432 (Entity (Get_Rep_Item (Typ, Name_Default_Value))));
9437 if not Has_Rep_Item (Typ, Name_Discard_Names, False)
9438 and then Has_Rep_Item (Typ, Name_Discard_Names)
9439 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9440 (Get_Rep_Item (Typ, Name_Discard_Names))
9442 Set_Discard_Names (Typ);
9447 if not Has_Rep_Item (Typ, Name_Invariant, False)
9448 and then Has_Rep_Item (Typ, Name_Invariant)
9449 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9450 (Get_Rep_Item (Typ, Name_Invariant))
9452 Set_Has_Invariants (Typ);
9454 if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then
9455 Set_Has_Inheritable_Invariants (Typ);
9461 if not Has_Rep_Item (Typ, Name_Volatile, False)
9462 and then Has_Rep_Item (Typ, Name_Volatile)
9463 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9464 (Get_Rep_Item (Typ, Name_Volatile))
9466 Set_Treat_As_Volatile (Typ);
9467 Set_Is_Volatile (Typ);
9470 -- Inheritance for derived types only
9472 if Is_Derived_Type (Typ) then
9474 Bas_Typ : constant Entity_Id := Base_Type (Typ);
9475 Imp_Bas_Typ : constant Entity_Id := Implementation_Base_Type (Typ);
9478 -- Atomic_Components
9480 if not Has_Rep_Item (Typ, Name_Atomic_Components, False)
9481 and then Has_Rep_Item (Typ, Name_Atomic_Components)
9482 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9483 (Get_Rep_Item (Typ, Name_Atomic_Components))
9485 Set_Has_Atomic_Components (Imp_Bas_Typ);
9488 -- Volatile_Components
9490 if not Has_Rep_Item (Typ, Name_Volatile_Components, False)
9491 and then Has_Rep_Item (Typ, Name_Volatile_Components)
9492 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9493 (Get_Rep_Item (Typ, Name_Volatile_Components))
9495 Set_Has_Volatile_Components (Imp_Bas_Typ);
9498 -- Finalize_Storage_Only.
9500 if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False)
9501 and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only)
9503 Set_Finalize_Storage_Only (Bas_Typ);
9506 -- Universal_Aliasing
9508 if not Has_Rep_Item (Typ, Name_Universal_Aliasing, False)
9509 and then Has_Rep_Item (Typ, Name_Universal_Aliasing)
9510 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
9511 (Get_Rep_Item (Typ, Name_Universal_Aliasing))
9513 Set_Universal_Aliasing (Imp_Bas_Typ);
9516 -- Record type specific aspects
9518 if Is_Record_Type (Typ) then
9522 if not Has_Rep_Item (Typ, Name_Bit_Order, False)
9523 and then Has_Rep_Item (Typ, Name_Bit_Order)
9525 Set_Reverse_Bit_Order (Bas_Typ,
9526 Reverse_Bit_Order (Entity (Name
9527 (Get_Rep_Item (Typ, Name_Bit_Order)))));
9530 -- Scalar_Storage_Order
9532 if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False)
9533 and then Has_Rep_Item (Typ, Name_Scalar_Storage_Order)
9535 Set_Reverse_Storage_Order (Bas_Typ,
9536 Reverse_Storage_Order (Entity (Name
9537 (Get_Rep_Item (Typ, Name_Scalar_Storage_Order)))));
9542 end Inherit_Aspects_At_Freeze_Point;
9548 procedure Initialize is
9550 Address_Clause_Checks.Init;
9551 Independence_Checks.Init;
9552 Unchecked_Conversions.Init;
9555 -------------------------
9556 -- Is_Operational_Item --
9557 -------------------------
9559 function Is_Operational_Item (N : Node_Id) return Boolean is
9561 if Nkind (N) /= N_Attribute_Definition_Clause then
9566 Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
9568 return Id = Attribute_Input
9569 or else Id = Attribute_Output
9570 or else Id = Attribute_Read
9571 or else Id = Attribute_Write
9572 or else Id = Attribute_External_Tag;
9575 end Is_Operational_Item;
9581 function Minimum_Size
9583 Biased : Boolean := False) return Nat
9585 Lo : Uint := No_Uint;
9586 Hi : Uint := No_Uint;
9587 LoR : Ureal := No_Ureal;
9588 HiR : Ureal := No_Ureal;
9589 LoSet : Boolean := False;
9590 HiSet : Boolean := False;
9594 R_Typ : constant Entity_Id := Root_Type (T);
9597 -- If bad type, return 0
9599 if T = Any_Type then
9602 -- For generic types, just return zero. There cannot be any legitimate
9603 -- need to know such a size, but this routine may be called with a
9604 -- generic type as part of normal processing.
9606 elsif Is_Generic_Type (R_Typ)
9607 or else R_Typ = Any_Type
9611 -- Access types. Normally an access type cannot have a size smaller
9612 -- than the size of System.Address. The exception is on VMS, where
9613 -- we have short and long addresses, and it is possible for an access
9614 -- type to have a short address size (and thus be less than the size
9615 -- of System.Address itself). We simply skip the check for VMS, and
9616 -- leave it to the back end to do the check.
9618 elsif Is_Access_Type (T) then
9619 if OpenVMS_On_Target then
9622 return System_Address_Size;
9625 -- Floating-point types
9627 elsif Is_Floating_Point_Type (T) then
9628 return UI_To_Int (Esize (R_Typ));
9632 elsif Is_Discrete_Type (T) then
9634 -- The following loop is looking for the nearest compile time known
9635 -- bounds following the ancestor subtype chain. The idea is to find
9636 -- the most restrictive known bounds information.
9640 if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
9645 if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then
9646 Lo := Expr_Rep_Value (Type_Low_Bound (Ancest));
9653 if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then
9654 Hi := Expr_Rep_Value (Type_High_Bound (Ancest));
9660 Ancest := Ancestor_Subtype (Ancest);
9663 Ancest := Base_Type (T);
9665 if Is_Generic_Type (Ancest) then
9671 -- Fixed-point types. We can't simply use Expr_Value to get the
9672 -- Corresponding_Integer_Value values of the bounds, since these do not
9673 -- get set till the type is frozen, and this routine can be called
9674 -- before the type is frozen. Similarly the test for bounds being static
9675 -- needs to include the case where we have unanalyzed real literals for
9678 elsif Is_Fixed_Point_Type (T) then
9680 -- The following loop is looking for the nearest compile time known
9681 -- bounds following the ancestor subtype chain. The idea is to find
9682 -- the most restrictive known bounds information.
9686 if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
9690 -- Note: In the following two tests for LoSet and HiSet, it may
9691 -- seem redundant to test for N_Real_Literal here since normally
9692 -- one would assume that the test for the value being known at
9693 -- compile time includes this case. However, there is a glitch.
9694 -- If the real literal comes from folding a non-static expression,
9695 -- then we don't consider any non- static expression to be known
9696 -- at compile time if we are in configurable run time mode (needed
9697 -- in some cases to give a clearer definition of what is and what
9698 -- is not accepted). So the test is indeed needed. Without it, we
9699 -- would set neither Lo_Set nor Hi_Set and get an infinite loop.
9702 if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
9703 or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
9705 LoR := Expr_Value_R (Type_Low_Bound (Ancest));
9712 if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal
9713 or else Compile_Time_Known_Value (Type_High_Bound (Ancest))
9715 HiR := Expr_Value_R (Type_High_Bound (Ancest));
9721 Ancest := Ancestor_Subtype (Ancest);
9724 Ancest := Base_Type (T);
9726 if Is_Generic_Type (Ancest) then
9732 Lo := UR_To_Uint (LoR / Small_Value (T));
9733 Hi := UR_To_Uint (HiR / Small_Value (T));
9735 -- No other types allowed
9738 raise Program_Error;
9741 -- Fall through with Hi and Lo set. Deal with biased case
9744 and then not Is_Fixed_Point_Type (T)
9745 and then not (Is_Enumeration_Type (T)
9746 and then Has_Non_Standard_Rep (T)))
9747 or else Has_Biased_Representation (T)
9753 -- Signed case. Note that we consider types like range 1 .. -1 to be
9754 -- signed for the purpose of computing the size, since the bounds have
9755 -- to be accommodated in the base type.
9757 if Lo < 0 or else Hi < 0 then
9761 -- S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
9762 -- Note that we accommodate the case where the bounds cross. This
9763 -- can happen either because of the way the bounds are declared
9764 -- or because of the algorithm in Freeze_Fixed_Point_Type.
9778 -- If both bounds are positive, make sure that both are represen-
9779 -- table in the case where the bounds are crossed. This can happen
9780 -- either because of the way the bounds are declared, or because of
9781 -- the algorithm in Freeze_Fixed_Point_Type.
9787 -- S = size, (can accommodate 0 .. (2**size - 1))
9790 while Hi >= Uint_2 ** S loop
9798 ---------------------------
9799 -- New_Stream_Subprogram --
9800 ---------------------------
9802 procedure New_Stream_Subprogram
9806 Nam : TSS_Name_Type)
9808 Loc : constant Source_Ptr := Sloc (N);
9809 Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam);
9810 Subp_Id : Entity_Id;
9811 Subp_Decl : Node_Id;
9815 Defer_Declaration : constant Boolean :=
9816 Is_Tagged_Type (Ent) or else Is_Private_Type (Ent);
9817 -- For a tagged type, there is a declaration for each stream attribute
9818 -- at the freeze point, and we must generate only a completion of this
9819 -- declaration. We do the same for private types, because the full view
9820 -- might be tagged. Otherwise we generate a declaration at the point of
9821 -- the attribute definition clause.
9823 function Build_Spec return Node_Id;
9824 -- Used for declaration and renaming declaration, so that this is
9825 -- treated as a renaming_as_body.
9831 function Build_Spec return Node_Id is
9832 Out_P : constant Boolean := (Nam = TSS_Stream_Read);
9835 T_Ref : constant Node_Id := New_Reference_To (Etyp, Loc);
9838 Subp_Id := Make_Defining_Identifier (Loc, Sname);
9840 -- S : access Root_Stream_Type'Class
9842 Formals := New_List (
9843 Make_Parameter_Specification (Loc,
9844 Defining_Identifier =>
9845 Make_Defining_Identifier (Loc, Name_S),
9847 Make_Access_Definition (Loc,
9850 Designated_Type (Etype (F)), Loc))));
9852 if Nam = TSS_Stream_Input then
9854 Make_Function_Specification (Loc,
9855 Defining_Unit_Name => Subp_Id,
9856 Parameter_Specifications => Formals,
9857 Result_Definition => T_Ref);
9862 Make_Parameter_Specification (Loc,
9863 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
9864 Out_Present => Out_P,
9865 Parameter_Type => T_Ref));
9868 Make_Procedure_Specification (Loc,
9869 Defining_Unit_Name => Subp_Id,
9870 Parameter_Specifications => Formals);
9876 -- Start of processing for New_Stream_Subprogram
9879 F := First_Formal (Subp);
9881 if Ekind (Subp) = E_Procedure then
9882 Etyp := Etype (Next_Formal (F));
9884 Etyp := Etype (Subp);
9887 -- Prepare subprogram declaration and insert it as an action on the
9888 -- clause node. The visibility for this entity is used to test for
9889 -- visibility of the attribute definition clause (in the sense of
9890 -- 8.3(23) as amended by AI-195).
9892 if not Defer_Declaration then
9894 Make_Subprogram_Declaration (Loc,
9895 Specification => Build_Spec);
9897 -- For a tagged type, there is always a visible declaration for each
9898 -- stream TSS (it is a predefined primitive operation), and the
9899 -- completion of this declaration occurs at the freeze point, which is
9900 -- not always visible at places where the attribute definition clause is
9901 -- visible. So, we create a dummy entity here for the purpose of
9902 -- tracking the visibility of the attribute definition clause itself.
9906 Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V'));
9908 Make_Object_Declaration (Loc,
9909 Defining_Identifier => Subp_Id,
9910 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc));
9913 Insert_Action (N, Subp_Decl);
9914 Set_Entity (N, Subp_Id);
9917 Make_Subprogram_Renaming_Declaration (Loc,
9918 Specification => Build_Spec,
9919 Name => New_Reference_To (Subp, Loc));
9921 if Defer_Declaration then
9922 Set_TSS (Base_Type (Ent), Subp_Id);
9924 Insert_Action (N, Subp_Decl);
9925 Copy_TSS (Subp_Id, Base_Type (Ent));
9927 end New_Stream_Subprogram;
9929 ------------------------
9930 -- Rep_Item_Too_Early --
9931 ------------------------
9933 function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is
9935 -- Cannot apply non-operational rep items to generic types
9937 if Is_Operational_Item (N) then
9941 and then Is_Generic_Type (Root_Type (T))
9943 Error_Msg_N ("representation item not allowed for generic type", N);
9947 -- Otherwise check for incomplete type
9949 if Is_Incomplete_Or_Private_Type (T)
9950 and then No (Underlying_Type (T))
9952 (Nkind (N) /= N_Pragma
9953 or else Get_Pragma_Id (N) /= Pragma_Import)
9956 ("representation item must be after full type declaration", N);
9959 -- If the type has incomplete components, a representation clause is
9960 -- illegal but stream attributes and Convention pragmas are correct.
9962 elsif Has_Private_Component (T) then
9963 if Nkind (N) = N_Pragma then
9968 ("representation item must appear after type is fully defined",
9975 end Rep_Item_Too_Early;
9977 -----------------------
9978 -- Rep_Item_Too_Late --
9979 -----------------------
9981 function Rep_Item_Too_Late
9984 FOnly : Boolean := False) return Boolean
9987 Parent_Type : Entity_Id;
9990 -- Output the too late message. Note that this is not considered a
9991 -- serious error, since the effect is simply that we ignore the
9992 -- representation clause in this case.
9998 procedure Too_Late is
10000 -- Other compilers seem more relaxed about rep items appearing too
10001 -- late. Since analysis tools typically don't care about rep items
10002 -- anyway, no reason to be too strict about this.
10004 if not Relaxed_RM_Semantics then
10005 Error_Msg_N ("|representation item appears too late!", N);
10009 -- Start of processing for Rep_Item_Too_Late
10012 -- First make sure entity is not frozen (RM 13.1(9))
10016 -- Exclude imported types, which may be frozen if they appear in a
10017 -- representation clause for a local type.
10019 and then not From_With_Type (T)
10021 -- Exclude generated entities (not coming from source). The common
10022 -- case is when we generate a renaming which prematurely freezes the
10023 -- renamed internal entity, but we still want to be able to set copies
10024 -- of attribute values such as Size/Alignment.
10026 and then Comes_From_Source (T)
10029 S := First_Subtype (T);
10031 if Present (Freeze_Node (S)) then
10033 ("??no more representation items for }", Freeze_Node (S), S);
10038 -- Check for case of non-tagged derived type whose parent either has
10039 -- primitive operations, or is a by reference type (RM 13.1(10)).
10043 and then Is_Derived_Type (T)
10044 and then not Is_Tagged_Type (T)
10046 Parent_Type := Etype (Base_Type (T));
10048 if Has_Primitive_Operations (Parent_Type) then
10051 ("primitive operations already defined for&!", N, Parent_Type);
10054 elsif Is_By_Reference_Type (Parent_Type) then
10057 ("parent type & is a by reference type!", N, Parent_Type);
10062 -- No error, link item into head of chain of rep items for the entity,
10063 -- but avoid chaining if we have an overloadable entity, and the pragma
10064 -- is one that can apply to multiple overloaded entities.
10066 if Is_Overloadable (T) and then Nkind (N) = N_Pragma then
10068 Pname : constant Name_Id := Pragma_Name (N);
10070 if Nam_In (Pname, Name_Convention, Name_Import, Name_Export,
10071 Name_External, Name_Interface)
10078 Record_Rep_Item (T, N);
10080 end Rep_Item_Too_Late;
10082 -------------------------------------
10083 -- Replace_Type_References_Generic --
10084 -------------------------------------
10086 procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is
10088 function Replace_Node (N : Node_Id) return Traverse_Result;
10089 -- Processes a single node in the traversal procedure below, checking
10090 -- if node N should be replaced, and if so, doing the replacement.
10092 procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node);
10093 -- This instantiation provides the body of Replace_Type_References
10099 function Replace_Node (N : Node_Id) return Traverse_Result is
10104 -- Case of identifier
10106 if Nkind (N) = N_Identifier then
10108 -- If not the type name, all done with this node
10110 if Chars (N) /= TName then
10113 -- Otherwise do the replacement and we are done with this node
10116 Replace_Type_Reference (N);
10120 -- Case of selected component (which is what a qualification
10121 -- looks like in the unanalyzed tree, which is what we have.
10123 elsif Nkind (N) = N_Selected_Component then
10125 -- If selector name is not our type, keeping going (we might
10126 -- still have an occurrence of the type in the prefix).
10128 if Nkind (Selector_Name (N)) /= N_Identifier
10129 or else Chars (Selector_Name (N)) /= TName
10133 -- Selector name is our type, check qualification
10136 -- Loop through scopes and prefixes, doing comparison
10138 S := Current_Scope;
10141 -- Continue if no more scopes or scope with no name
10143 if No (S) or else Nkind (S) not in N_Has_Chars then
10147 -- Do replace if prefix is an identifier matching the
10148 -- scope that we are currently looking at.
10150 if Nkind (P) = N_Identifier
10151 and then Chars (P) = Chars (S)
10153 Replace_Type_Reference (N);
10157 -- Go check scope above us if prefix is itself of the
10158 -- form of a selected component, whose selector matches
10159 -- the scope we are currently looking at.
10161 if Nkind (P) = N_Selected_Component
10162 and then Nkind (Selector_Name (P)) = N_Identifier
10163 and then Chars (Selector_Name (P)) = Chars (S)
10168 -- For anything else, we don't have a match, so keep on
10169 -- going, there are still some weird cases where we may
10170 -- still have a replacement within the prefix.
10178 -- Continue for any other node kind
10186 Replace_Type_Refs (N);
10187 end Replace_Type_References_Generic;
10189 -------------------------
10190 -- Same_Representation --
10191 -------------------------
10193 function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is
10194 T1 : constant Entity_Id := Underlying_Type (Typ1);
10195 T2 : constant Entity_Id := Underlying_Type (Typ2);
10198 -- A quick check, if base types are the same, then we definitely have
10199 -- the same representation, because the subtype specific representation
10200 -- attributes (Size and Alignment) do not affect representation from
10201 -- the point of view of this test.
10203 if Base_Type (T1) = Base_Type (T2) then
10206 elsif Is_Private_Type (Base_Type (T2))
10207 and then Base_Type (T1) = Full_View (Base_Type (T2))
10212 -- Tagged types never have differing representations
10214 if Is_Tagged_Type (T1) then
10218 -- Representations are definitely different if conventions differ
10220 if Convention (T1) /= Convention (T2) then
10224 -- Representations are different if component alignments or scalar
10225 -- storage orders differ.
10227 if (Is_Record_Type (T1) or else Is_Array_Type (T1))
10229 (Is_Record_Type (T2) or else Is_Array_Type (T2))
10231 (Component_Alignment (T1) /= Component_Alignment (T2)
10233 Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
10238 -- For arrays, the only real issue is component size. If we know the
10239 -- component size for both arrays, and it is the same, then that's
10240 -- good enough to know we don't have a change of representation.
10242 if Is_Array_Type (T1) then
10243 if Known_Component_Size (T1)
10244 and then Known_Component_Size (T2)
10245 and then Component_Size (T1) = Component_Size (T2)
10247 if VM_Target = No_VM then
10250 -- In VM targets the representation of arrays with aliased
10251 -- components differs from arrays with non-aliased components
10254 return Has_Aliased_Components (Base_Type (T1))
10256 Has_Aliased_Components (Base_Type (T2));
10261 -- Types definitely have same representation if neither has non-standard
10262 -- representation since default representations are always consistent.
10263 -- If only one has non-standard representation, and the other does not,
10264 -- then we consider that they do not have the same representation. They
10265 -- might, but there is no way of telling early enough.
10267 if Has_Non_Standard_Rep (T1) then
10268 if not Has_Non_Standard_Rep (T2) then
10272 return not Has_Non_Standard_Rep (T2);
10275 -- Here the two types both have non-standard representation, and we need
10276 -- to determine if they have the same non-standard representation.
10278 -- For arrays, we simply need to test if the component sizes are the
10279 -- same. Pragma Pack is reflected in modified component sizes, so this
10280 -- check also deals with pragma Pack.
10282 if Is_Array_Type (T1) then
10283 return Component_Size (T1) = Component_Size (T2);
10285 -- Tagged types always have the same representation, because it is not
10286 -- possible to specify different representations for common fields.
10288 elsif Is_Tagged_Type (T1) then
10291 -- Case of record types
10293 elsif Is_Record_Type (T1) then
10295 -- Packed status must conform
10297 if Is_Packed (T1) /= Is_Packed (T2) then
10300 -- Otherwise we must check components. Typ2 maybe a constrained
10301 -- subtype with fewer components, so we compare the components
10302 -- of the base types.
10305 Record_Case : declare
10306 CD1, CD2 : Entity_Id;
10308 function Same_Rep return Boolean;
10309 -- CD1 and CD2 are either components or discriminants. This
10310 -- function tests whether they have the same representation.
10316 function Same_Rep return Boolean is
10318 if No (Component_Clause (CD1)) then
10319 return No (Component_Clause (CD2));
10321 -- Note: at this point, component clauses have been
10322 -- normalized to the default bit order, so that the
10323 -- comparison of Component_Bit_Offsets is meaningful.
10326 Present (Component_Clause (CD2))
10328 Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2)
10330 Esize (CD1) = Esize (CD2);
10334 -- Start of processing for Record_Case
10337 if Has_Discriminants (T1) then
10339 -- The number of discriminants may be different if the
10340 -- derived type has fewer (constrained by values). The
10341 -- invisible discriminants retain the representation of
10342 -- the original, so the discrepancy does not per se
10343 -- indicate a different representation.
10345 CD1 := First_Discriminant (T1);
10346 CD2 := First_Discriminant (T2);
10347 while Present (CD1) and then Present (CD2) loop
10348 if not Same_Rep then
10351 Next_Discriminant (CD1);
10352 Next_Discriminant (CD2);
10357 CD1 := First_Component (Underlying_Type (Base_Type (T1)));
10358 CD2 := First_Component (Underlying_Type (Base_Type (T2)));
10359 while Present (CD1) loop
10360 if not Same_Rep then
10363 Next_Component (CD1);
10364 Next_Component (CD2);
10372 -- For enumeration types, we must check each literal to see if the
10373 -- representation is the same. Note that we do not permit enumeration
10374 -- representation clauses for Character and Wide_Character, so these
10375 -- cases were already dealt with.
10377 elsif Is_Enumeration_Type (T1) then
10378 Enumeration_Case : declare
10379 L1, L2 : Entity_Id;
10382 L1 := First_Literal (T1);
10383 L2 := First_Literal (T2);
10384 while Present (L1) loop
10385 if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
10394 end Enumeration_Case;
10396 -- Any other types have the same representation for these purposes
10401 end Same_Representation;
10407 procedure Set_Biased
10411 Biased : Boolean := True)
10415 Set_Has_Biased_Representation (E);
10417 if Warn_On_Biased_Representation then
10419 ("?B?" & Msg & " forces biased representation for&", N, E);
10424 --------------------
10425 -- Set_Enum_Esize --
10426 --------------------
10428 procedure Set_Enum_Esize (T : Entity_Id) is
10434 Init_Alignment (T);
10436 -- Find the minimum standard size (8,16,32,64) that fits
10438 Lo := Enumeration_Rep (Entity (Type_Low_Bound (T)));
10439 Hi := Enumeration_Rep (Entity (Type_High_Bound (T)));
10442 if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then
10443 Sz := Standard_Character_Size; -- May be > 8 on some targets
10445 elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then
10448 elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then
10451 else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63);
10456 if Hi < Uint_2**08 then
10457 Sz := Standard_Character_Size; -- May be > 8 on some targets
10459 elsif Hi < Uint_2**16 then
10462 elsif Hi < Uint_2**32 then
10465 else pragma Assert (Hi < Uint_2**63);
10470 -- That minimum is the proper size unless we have a foreign convention
10471 -- and the size required is 32 or less, in which case we bump the size
10472 -- up to 32. This is required for C and C++ and seems reasonable for
10473 -- all other foreign conventions.
10475 if Has_Foreign_Convention (T)
10476 and then Esize (T) < Standard_Integer_Size
10478 Init_Esize (T, Standard_Integer_Size);
10480 Init_Esize (T, Sz);
10482 end Set_Enum_Esize;
10484 ------------------------------
10485 -- Validate_Address_Clauses --
10486 ------------------------------
10488 procedure Validate_Address_Clauses is
10490 for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop
10492 ACCR : Address_Clause_Check_Record
10493 renames Address_Clause_Checks.Table (J);
10497 X_Alignment : Uint;
10498 Y_Alignment : Uint;
10504 -- Skip processing of this entry if warning already posted
10506 if not Address_Warning_Posted (ACCR.N) then
10507 Expr := Original_Node (Expression (ACCR.N));
10511 X_Alignment := Alignment (ACCR.X);
10512 Y_Alignment := Alignment (ACCR.Y);
10514 -- Similarly obtain sizes
10516 X_Size := Esize (ACCR.X);
10517 Y_Size := Esize (ACCR.Y);
10519 -- Check for large object overlaying smaller one
10522 and then X_Size > Uint_0
10523 and then X_Size > Y_Size
10526 ("?& overlays smaller object", ACCR.N, ACCR.X);
10528 ("\??program execution may be erroneous", ACCR.N);
10529 Error_Msg_Uint_1 := X_Size;
10531 ("\??size of & is ^", ACCR.N, ACCR.X);
10532 Error_Msg_Uint_1 := Y_Size;
10534 ("\??size of & is ^", ACCR.N, ACCR.Y);
10536 -- Check for inadequate alignment, both of the base object
10537 -- and of the offset, if any.
10539 -- Note: we do not check the alignment if we gave a size
10540 -- warning, since it would likely be redundant.
10542 elsif Y_Alignment /= Uint_0
10543 and then (Y_Alignment < X_Alignment
10546 Nkind (Expr) = N_Attribute_Reference
10548 Attribute_Name (Expr) = Name_Address
10550 Has_Compatible_Alignment
10551 (ACCR.X, Prefix (Expr))
10552 /= Known_Compatible))
10555 ("??specified address for& may be inconsistent "
10556 & "with alignment", ACCR.N, ACCR.X);
10558 ("\??program execution may be erroneous (RM 13.3(27))",
10560 Error_Msg_Uint_1 := X_Alignment;
10562 ("\??alignment of & is ^", ACCR.N, ACCR.X);
10563 Error_Msg_Uint_1 := Y_Alignment;
10565 ("\??alignment of & is ^", ACCR.N, ACCR.Y);
10566 if Y_Alignment >= X_Alignment then
10568 ("\??but offset is not multiple of alignment", ACCR.N);
10574 end Validate_Address_Clauses;
10576 ---------------------------
10577 -- Validate_Independence --
10578 ---------------------------
10580 procedure Validate_Independence is
10581 SU : constant Uint := UI_From_Int (System_Storage_Unit);
10589 procedure Check_Array_Type (Atyp : Entity_Id);
10590 -- Checks if the array type Atyp has independent components, and
10591 -- if not, outputs an appropriate set of error messages.
10593 procedure No_Independence;
10594 -- Output message that independence cannot be guaranteed
10596 function OK_Component (C : Entity_Id) return Boolean;
10597 -- Checks one component to see if it is independently accessible, and
10598 -- if so yields True, otherwise yields False if independent access
10599 -- cannot be guaranteed. This is a conservative routine, it only
10600 -- returns True if it knows for sure, it returns False if it knows
10601 -- there is a problem, or it cannot be sure there is no problem.
10603 procedure Reason_Bad_Component (C : Entity_Id);
10604 -- Outputs continuation message if a reason can be determined for
10605 -- the component C being bad.
10607 ----------------------
10608 -- Check_Array_Type --
10609 ----------------------
10611 procedure Check_Array_Type (Atyp : Entity_Id) is
10612 Ctyp : constant Entity_Id := Component_Type (Atyp);
10615 -- OK if no alignment clause, no pack, and no component size
10617 if not Has_Component_Size_Clause (Atyp)
10618 and then not Has_Alignment_Clause (Atyp)
10619 and then not Is_Packed (Atyp)
10624 -- Check actual component size
10626 if not Known_Component_Size (Atyp)
10627 or else not (Addressable (Component_Size (Atyp))
10628 and then Component_Size (Atyp) < 64)
10629 or else Component_Size (Atyp) mod Esize (Ctyp) /= 0
10633 -- Bad component size, check reason
10635 if Has_Component_Size_Clause (Atyp) then
10636 P := Get_Attribute_Definition_Clause
10637 (Atyp, Attribute_Component_Size);
10639 if Present (P) then
10640 Error_Msg_Sloc := Sloc (P);
10641 Error_Msg_N ("\because of Component_Size clause#", N);
10646 if Is_Packed (Atyp) then
10647 P := Get_Rep_Pragma (Atyp, Name_Pack);
10649 if Present (P) then
10650 Error_Msg_Sloc := Sloc (P);
10651 Error_Msg_N ("\because of pragma Pack#", N);
10656 -- No reason found, just return
10661 -- Array type is OK independence-wise
10664 end Check_Array_Type;
10666 ---------------------
10667 -- No_Independence --
10668 ---------------------
10670 procedure No_Independence is
10672 if Pragma_Name (N) = Name_Independent then
10673 Error_Msg_NE ("independence cannot be guaranteed for&", N, E);
10676 ("independent components cannot be guaranteed for&", N, E);
10678 end No_Independence;
10684 function OK_Component (C : Entity_Id) return Boolean is
10685 Rec : constant Entity_Id := Scope (C);
10686 Ctyp : constant Entity_Id := Etype (C);
10689 -- OK if no component clause, no Pack, and no alignment clause
10691 if No (Component_Clause (C))
10692 and then not Is_Packed (Rec)
10693 and then not Has_Alignment_Clause (Rec)
10698 -- Here we look at the actual component layout. A component is
10699 -- addressable if its size is a multiple of the Esize of the
10700 -- component type, and its starting position in the record has
10701 -- appropriate alignment, and the record itself has appropriate
10702 -- alignment to guarantee the component alignment.
10704 -- Make sure sizes are static, always assume the worst for any
10705 -- cases where we cannot check static values.
10707 if not (Known_Static_Esize (C)
10709 Known_Static_Esize (Ctyp))
10714 -- Size of component must be addressable or greater than 64 bits
10715 -- and a multiple of bytes.
10717 if not Addressable (Esize (C)) and then Esize (C) < Uint_64 then
10721 -- Check size is proper multiple
10723 if Esize (C) mod Esize (Ctyp) /= 0 then
10727 -- Check alignment of component is OK
10729 if not Known_Component_Bit_Offset (C)
10730 or else Component_Bit_Offset (C) < Uint_0
10731 or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0
10736 -- Check alignment of record type is OK
10738 if not Known_Alignment (Rec)
10739 or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
10744 -- All tests passed, component is addressable
10749 --------------------------
10750 -- Reason_Bad_Component --
10751 --------------------------
10753 procedure Reason_Bad_Component (C : Entity_Id) is
10754 Rec : constant Entity_Id := Scope (C);
10755 Ctyp : constant Entity_Id := Etype (C);
10758 -- If component clause present assume that's the problem
10760 if Present (Component_Clause (C)) then
10761 Error_Msg_Sloc := Sloc (Component_Clause (C));
10762 Error_Msg_N ("\because of Component_Clause#", N);
10766 -- If pragma Pack clause present, assume that's the problem
10768 if Is_Packed (Rec) then
10769 P := Get_Rep_Pragma (Rec, Name_Pack);
10771 if Present (P) then
10772 Error_Msg_Sloc := Sloc (P);
10773 Error_Msg_N ("\because of pragma Pack#", N);
10778 -- See if record has bad alignment clause
10780 if Has_Alignment_Clause (Rec)
10781 and then Known_Alignment (Rec)
10782 and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
10784 P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment);
10786 if Present (P) then
10787 Error_Msg_Sloc := Sloc (P);
10788 Error_Msg_N ("\because of Alignment clause#", N);
10792 -- Couldn't find a reason, so return without a message
10795 end Reason_Bad_Component;
10797 -- Start of processing for Validate_Independence
10800 for J in Independence_Checks.First .. Independence_Checks.Last loop
10801 N := Independence_Checks.Table (J).N;
10802 E := Independence_Checks.Table (J).E;
10803 IC := Pragma_Name (N) = Name_Independent_Components;
10805 -- Deal with component case
10807 if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then
10808 if not OK_Component (E) then
10810 Reason_Bad_Component (E);
10815 -- Deal with record with Independent_Components
10817 if IC and then Is_Record_Type (E) then
10818 Comp := First_Component_Or_Discriminant (E);
10819 while Present (Comp) loop
10820 if not OK_Component (Comp) then
10822 Reason_Bad_Component (Comp);
10826 Next_Component_Or_Discriminant (Comp);
10830 -- Deal with address clause case
10832 if Is_Object (E) then
10833 Addr := Address_Clause (E);
10835 if Present (Addr) then
10837 Error_Msg_Sloc := Sloc (Addr);
10838 Error_Msg_N ("\because of Address clause#", N);
10843 -- Deal with independent components for array type
10845 if IC and then Is_Array_Type (E) then
10846 Check_Array_Type (E);
10849 -- Deal with independent components for array object
10851 if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then
10852 Check_Array_Type (Etype (E));
10857 end Validate_Independence;
10859 -----------------------------------
10860 -- Validate_Unchecked_Conversion --
10861 -----------------------------------
10863 procedure Validate_Unchecked_Conversion
10865 Act_Unit : Entity_Id)
10867 Source : Entity_Id;
10868 Target : Entity_Id;
10872 -- Obtain source and target types. Note that we call Ancestor_Subtype
10873 -- here because the processing for generic instantiation always makes
10874 -- subtypes, and we want the original frozen actual types.
10876 -- If we are dealing with private types, then do the check on their
10877 -- fully declared counterparts if the full declarations have been
10878 -- encountered (they don't have to be visible, but they must exist!)
10880 Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit)));
10882 if Is_Private_Type (Source)
10883 and then Present (Underlying_Type (Source))
10885 Source := Underlying_Type (Source);
10888 Target := Ancestor_Subtype (Etype (Act_Unit));
10890 -- If either type is generic, the instantiation happens within a generic
10891 -- unit, and there is nothing to check. The proper check will happen
10892 -- when the enclosing generic is instantiated.
10894 if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
10898 if Is_Private_Type (Target)
10899 and then Present (Underlying_Type (Target))
10901 Target := Underlying_Type (Target);
10904 -- Source may be unconstrained array, but not target
10906 if Is_Array_Type (Target) and then not Is_Constrained (Target) then
10908 ("unchecked conversion to unconstrained array not allowed", N);
10912 -- Warn if conversion between two different convention pointers
10914 if Is_Access_Type (Target)
10915 and then Is_Access_Type (Source)
10916 and then Convention (Target) /= Convention (Source)
10917 and then Warn_On_Unchecked_Conversion
10919 -- Give warnings for subprogram pointers only on most targets. The
10920 -- exception is VMS, where data pointers can have different lengths
10921 -- depending on the pointer convention.
10923 if Is_Access_Subprogram_Type (Target)
10924 or else Is_Access_Subprogram_Type (Source)
10925 or else OpenVMS_On_Target
10928 ("?z?conversion between pointers with different conventions!",
10933 -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a
10934 -- warning when compiling GNAT-related sources.
10936 if Warn_On_Unchecked_Conversion
10937 and then not In_Predefined_Unit (N)
10938 and then RTU_Loaded (Ada_Calendar)
10940 (Chars (Source) = Name_Time
10942 Chars (Target) = Name_Time)
10944 -- If Ada.Calendar is loaded and the name of one of the operands is
10945 -- Time, there is a good chance that this is Ada.Calendar.Time.
10948 Calendar_Time : constant Entity_Id :=
10949 Full_View (RTE (RO_CA_Time));
10951 pragma Assert (Present (Calendar_Time));
10953 if Source = Calendar_Time or else Target = Calendar_Time then
10955 ("?z?representation of 'Time values may change between " &
10956 "'G'N'A'T versions", N);
10961 -- Make entry in unchecked conversion table for later processing by
10962 -- Validate_Unchecked_Conversions, which will check sizes and alignments
10963 -- (using values set by the back-end where possible). This is only done
10964 -- if the appropriate warning is active.
10966 if Warn_On_Unchecked_Conversion then
10967 Unchecked_Conversions.Append
10968 (New_Val => UC_Entry'(Eloc => Sloc (N),
10970 Target => Target));
10972 -- If both sizes are known statically now, then back end annotation
10973 -- is not required to do a proper check but if either size is not
10974 -- known statically, then we need the annotation.
10976 if Known_Static_RM_Size (Source)
10978 Known_Static_RM_Size (Target)
10982 Back_Annotate_Rep_Info := True;
10986 -- If unchecked conversion to access type, and access type is declared
10987 -- in the same unit as the unchecked conversion, then set the flag
10988 -- No_Strict_Aliasing (no strict aliasing is implicit here)
10990 if Is_Access_Type (Target) and then
10991 In_Same_Source_Unit (Target, N)
10993 Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
10996 -- Generate N_Validate_Unchecked_Conversion node for back end in case
10997 -- the back end needs to perform special validation checks.
10999 -- Shouldn't this be in Exp_Ch13, since the check only gets done if we
11000 -- have full expansion and the back end is called ???
11003 Make_Validate_Unchecked_Conversion (Sloc (N));
11004 Set_Source_Type (Vnode, Source);
11005 Set_Target_Type (Vnode, Target);
11007 -- If the unchecked conversion node is in a list, just insert before it.
11008 -- If not we have some strange case, not worth bothering about.
11010 if Is_List_Member (N) then
11011 Insert_After (N, Vnode);
11013 end Validate_Unchecked_Conversion;
11015 ------------------------------------
11016 -- Validate_Unchecked_Conversions --
11017 ------------------------------------
11019 procedure Validate_Unchecked_Conversions is
11021 for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop
11023 T : UC_Entry renames Unchecked_Conversions.Table (N);
11025 Eloc : constant Source_Ptr := T.Eloc;
11026 Source : constant Entity_Id := T.Source;
11027 Target : constant Entity_Id := T.Target;
11033 -- This validation check, which warns if we have unequal sizes for
11034 -- unchecked conversion, and thus potentially implementation
11035 -- dependent semantics, is one of the few occasions on which we
11036 -- use the official RM size instead of Esize. See description in
11037 -- Einfo "Handling of Type'Size Values" for details.
11039 if Serious_Errors_Detected = 0
11040 and then Known_Static_RM_Size (Source)
11041 and then Known_Static_RM_Size (Target)
11043 -- Don't do the check if warnings off for either type, note the
11044 -- deliberate use of OR here instead of OR ELSE to get the flag
11045 -- Warnings_Off_Used set for both types if appropriate.
11047 and then not (Has_Warnings_Off (Source)
11049 Has_Warnings_Off (Target))
11051 Source_Siz := RM_Size (Source);
11052 Target_Siz := RM_Size (Target);
11054 if Source_Siz /= Target_Siz then
11056 ("?z?types for unchecked conversion have different sizes!",
11059 if All_Errors_Mode then
11060 Error_Msg_Name_1 := Chars (Source);
11061 Error_Msg_Uint_1 := Source_Siz;
11062 Error_Msg_Name_2 := Chars (Target);
11063 Error_Msg_Uint_2 := Target_Siz;
11064 Error_Msg ("\size of % is ^, size of % is ^?z?", Eloc);
11066 Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
11068 if Is_Discrete_Type (Source)
11070 Is_Discrete_Type (Target)
11072 if Source_Siz > Target_Siz then
11074 ("\?z?^ high order bits of source will "
11075 & "be ignored!", Eloc);
11077 elsif Is_Unsigned_Type (Source) then
11079 ("\?z?source will be extended with ^ high order "
11080 & "zero bits?!", Eloc);
11084 ("\?z?source will be extended with ^ high order "
11085 & "sign bits!", Eloc);
11088 elsif Source_Siz < Target_Siz then
11089 if Is_Discrete_Type (Target) then
11090 if Bytes_Big_Endian then
11092 ("\?z?target value will include ^ undefined "
11093 & "low order bits!", Eloc);
11096 ("\?z?target value will include ^ undefined "
11097 & "high order bits!", Eloc);
11102 ("\?z?^ trailing bits of target value will be "
11103 & "undefined!", Eloc);
11106 else pragma Assert (Source_Siz > Target_Siz);
11108 ("\?z?^ trailing bits of source will be ignored!",
11115 -- If both types are access types, we need to check the alignment.
11116 -- If the alignment of both is specified, we can do it here.
11118 if Serious_Errors_Detected = 0
11119 and then Ekind (Source) in Access_Kind
11120 and then Ekind (Target) in Access_Kind
11121 and then Target_Strict_Alignment
11122 and then Present (Designated_Type (Source))
11123 and then Present (Designated_Type (Target))
11126 D_Source : constant Entity_Id := Designated_Type (Source);
11127 D_Target : constant Entity_Id := Designated_Type (Target);
11130 if Known_Alignment (D_Source)
11132 Known_Alignment (D_Target)
11135 Source_Align : constant Uint := Alignment (D_Source);
11136 Target_Align : constant Uint := Alignment (D_Target);
11139 if Source_Align < Target_Align
11140 and then not Is_Tagged_Type (D_Source)
11142 -- Suppress warning if warnings suppressed on either
11143 -- type or either designated type. Note the use of
11144 -- OR here instead of OR ELSE. That is intentional,
11145 -- we would like to set flag Warnings_Off_Used in
11146 -- all types for which warnings are suppressed.
11148 and then not (Has_Warnings_Off (D_Source)
11150 Has_Warnings_Off (D_Target)
11152 Has_Warnings_Off (Source)
11154 Has_Warnings_Off (Target))
11156 Error_Msg_Uint_1 := Target_Align;
11157 Error_Msg_Uint_2 := Source_Align;
11158 Error_Msg_Node_1 := D_Target;
11159 Error_Msg_Node_2 := D_Source;
11161 ("?z?alignment of & (^) is stricter than "
11162 & "alignment of & (^)!", Eloc);
11164 ("\?z?resulting access value may have invalid "
11165 & "alignment!", Eloc);
11173 end Validate_Unchecked_Conversions;