1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
29 with Atree; use Atree;
30 with Checks; use Checks;
31 with Einfo; use Einfo;
32 with Errout; use Errout;
34 with Exp_Tss; use Exp_Tss;
35 with Exp_Util; use Exp_Util;
36 with Expander; use Expander;
37 with Freeze; use Freeze;
39 with Lib.Xref; use Lib.Xref;
40 with Namet; use Namet;
41 with Nlists; use Nlists;
42 with Nmake; use Nmake;
44 with Restrict; use Restrict;
45 with Rtsfind; use Rtsfind;
46 with Sdefault; use Sdefault;
48 with Sem_Cat; use Sem_Cat;
49 with Sem_Ch6; use Sem_Ch6;
50 with Sem_Ch8; use Sem_Ch8;
51 with Sem_Dist; use Sem_Dist;
52 with Sem_Eval; use Sem_Eval;
53 with Sem_Res; use Sem_Res;
54 with Sem_Type; use Sem_Type;
55 with Sem_Util; use Sem_Util;
56 with Stand; use Stand;
57 with Sinfo; use Sinfo;
58 with Sinput; use Sinput;
59 with Snames; use Snames;
61 with Stringt; use Stringt;
62 with Targparm; use Targparm;
63 with Ttypes; use Ttypes;
64 with Ttypef; use Ttypef;
65 with Tbuild; use Tbuild;
66 with Uintp; use Uintp;
67 with Urealp; use Urealp;
68 with Widechar; use Widechar;
70 package body Sem_Attr is
72 True_Value : constant Uint := Uint_1;
73 False_Value : constant Uint := Uint_0;
74 -- Synonyms to be used when these constants are used as Boolean values
76 Bad_Attribute : exception;
77 -- Exception raised if an error is detected during attribute processing,
78 -- used so that we can abandon the processing so we don't run into
79 -- trouble with cascaded errors.
81 -- The following array is the list of attributes defined in the Ada 83 RM
83 Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
89 Attribute_Constrained |
102 Attribute_Leading_Part |
104 Attribute_Machine_Emax |
105 Attribute_Machine_Emin |
106 Attribute_Machine_Mantissa |
107 Attribute_Machine_Overflows |
108 Attribute_Machine_Radix |
109 Attribute_Machine_Rounds |
115 Attribute_Safe_Emax |
116 Attribute_Safe_Large |
117 Attribute_Safe_Small |
120 Attribute_Storage_Size |
122 Attribute_Terminated |
125 Attribute_Width => True,
128 -----------------------
129 -- Local_Subprograms --
130 -----------------------
132 procedure Eval_Attribute (N : Node_Id);
133 -- Performs compile time evaluation of attributes where possible, leaving
134 -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately
135 -- set, and replacing the node with a literal node if the value can be
136 -- computed at compile time. All static attribute references are folded,
137 -- as well as a number of cases of non-static attributes that can always
138 -- be computed at compile time (e.g. floating-point model attributes that
139 -- are applied to non-static subtypes). Of course in such cases, the
140 -- Is_Static_Expression flag will not be set on the resulting literal.
141 -- Note that the only required action of this procedure is to catch the
142 -- static expression cases as described in the RM. Folding of other cases
143 -- is done where convenient, but some additional non-static folding is in
144 -- N_Expand_Attribute_Reference in cases where this is more convenient.
146 function Is_Anonymous_Tagged_Base
150 -- For derived tagged types that constrain parent discriminants we build
151 -- an anonymous unconstrained base type. We need to recognize the relation
152 -- between the two when analyzing an access attribute for a constrained
153 -- component, before the full declaration for Typ has been analyzed, and
154 -- where therefore the prefix of the attribute does not match the enclosing
157 -----------------------
158 -- Analyze_Attribute --
159 -----------------------
161 procedure Analyze_Attribute (N : Node_Id) is
162 Loc : constant Source_Ptr := Sloc (N);
163 Aname : constant Name_Id := Attribute_Name (N);
164 P : constant Node_Id := Prefix (N);
165 Exprs : constant List_Id := Expressions (N);
166 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
171 -- Type of prefix after analysis
173 P_Base_Type : Entity_Id;
174 -- Base type of prefix after analysis
176 -----------------------
177 -- Local Subprograms --
178 -----------------------
180 procedure Analyze_Access_Attribute;
181 -- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
182 -- Internally, Id distinguishes which of the three cases is involved.
184 procedure Check_Array_Or_Scalar_Type;
185 -- Common procedure used by First, Last, Range attribute to check
186 -- that the prefix is a constrained array or scalar type, or a name
187 -- of an array object, and that an argument appears only if appropriate
188 -- (i.e. only in the array case).
190 procedure Check_Array_Type;
191 -- Common semantic checks for all array attributes. Checks that the
192 -- prefix is a constrained array type or the name of an array object.
193 -- The error message for non-arrays is specialized appropriately.
195 procedure Check_Asm_Attribute;
196 -- Common semantic checks for Asm_Input and Asm_Output attributes
198 procedure Check_Component;
199 -- Common processing for Bit_Position, First_Bit, Last_Bit, and
200 -- Position. Checks prefix is an appropriate selected component.
202 procedure Check_Decimal_Fixed_Point_Type;
203 -- Check that prefix of attribute N is a decimal fixed-point type
205 procedure Check_Dereference;
206 -- If the prefix of attribute is an object of an access type, then
207 -- introduce an explicit deference, and adjust P_Type accordingly.
209 procedure Check_Discrete_Type;
210 -- Verify that prefix of attribute N is a discrete type
213 -- Check that no attribute arguments are present
215 procedure Check_Either_E0_Or_E1;
216 -- Check that there are zero or one attribute arguments present
219 -- Check that exactly one attribute argument is present
222 -- Check that two attribute arguments are present
224 procedure Check_Enum_Image;
225 -- If the prefix type is an enumeration type, set all its literals
226 -- as referenced, since the image function could possibly end up
227 -- referencing any of the literals indirectly.
229 procedure Check_Fixed_Point_Type;
230 -- Verify that prefix of attribute N is a fixed type
232 procedure Check_Fixed_Point_Type_0;
233 -- Verify that prefix of attribute N is a fixed type and that
234 -- no attribute expressions are present
236 procedure Check_Floating_Point_Type;
237 -- Verify that prefix of attribute N is a float type
239 procedure Check_Floating_Point_Type_0;
240 -- Verify that prefix of attribute N is a float type and that
241 -- no attribute expressions are present
243 procedure Check_Floating_Point_Type_1;
244 -- Verify that prefix of attribute N is a float type and that
245 -- exactly one attribute expression is present
247 procedure Check_Floating_Point_Type_2;
248 -- Verify that prefix of attribute N is a float type and that
249 -- two attribute expressions are present
251 procedure Legal_Formal_Attribute;
252 -- Common processing for attributes Definite, and Has_Discriminants
254 procedure Check_Integer_Type;
255 -- Verify that prefix of attribute N is an integer type
257 procedure Check_Library_Unit;
258 -- Verify that prefix of attribute N is a library unit
260 procedure Check_Not_Incomplete_Type;
261 -- Check that P (the prefix of the attribute) is not an incomplete
262 -- type or a private type for which no full view has been given.
264 procedure Check_Object_Reference (P : Node_Id);
265 -- Check that P (the prefix of the attribute) is an object reference
267 procedure Check_Program_Unit;
268 -- Verify that prefix of attribute N is a program unit
270 procedure Check_Real_Type;
271 -- Verify that prefix of attribute N is fixed or float type
273 procedure Check_Scalar_Type;
274 -- Verify that prefix of attribute N is a scalar type
276 procedure Check_Standard_Prefix;
277 -- Verify that prefix of attribute N is package Standard
279 procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
280 -- Validity checking for stream attribute. Nam is the TSS name of the
281 -- corresponding possible defined attribute function (e.g. for the
282 -- Read attribute, Nam will be TSS_Stream_Read).
284 procedure Check_Task_Prefix;
285 -- Verify that prefix of attribute N is a task or task type
287 procedure Check_Type;
288 -- Verify that the prefix of attribute N is a type
290 procedure Check_Unit_Name (Nod : Node_Id);
291 -- Check that Nod is of the form of a library unit name, i.e that
292 -- it is an identifier, or a selected component whose prefix is
293 -- itself of the form of a library unit name. Note that this is
294 -- quite different from Check_Program_Unit, since it only checks
295 -- the syntactic form of the name, not the semantic identity. This
296 -- is because it is used with attributes (Elab_Body, Elab_Spec, and
297 -- UET_Address) which can refer to non-visible unit.
299 procedure Error_Attr (Msg : String; Error_Node : Node_Id);
300 pragma No_Return (Error_Attr);
301 procedure Error_Attr;
302 pragma No_Return (Error_Attr);
303 -- Posts error using Error_Msg_N at given node, sets type of attribute
304 -- node to Any_Type, and then raises Bad_Attribute to avoid any further
305 -- semantic processing. The message typically contains a % insertion
306 -- character which is replaced by the attribute name. The call with
307 -- no arguments is used when the caller has already generated the
308 -- required error messages.
310 procedure Standard_Attribute (Val : Int);
311 -- Used to process attributes whose prefix is package Standard which
312 -- yield values of type Universal_Integer. The attribute reference
313 -- node is rewritten with an integer literal of the given value.
315 procedure Unexpected_Argument (En : Node_Id);
316 -- Signal unexpected attribute argument (En is the argument)
318 procedure Validate_Non_Static_Attribute_Function_Call;
319 -- Called when processing an attribute that is a function call to a
320 -- non-static function, i.e. an attribute function that either takes
321 -- non-scalar arguments or returns a non-scalar result. Verifies that
322 -- such a call does not appear in a preelaborable context.
324 ------------------------------
325 -- Analyze_Access_Attribute --
326 ------------------------------
328 procedure Analyze_Access_Attribute is
329 Acc_Type : Entity_Id;
334 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
335 -- Build an access-to-object type whose designated type is DT,
336 -- and whose Ekind is appropriate to the attribute type. The
337 -- type that is constructed is returned as the result.
339 procedure Build_Access_Subprogram_Type (P : Node_Id);
340 -- Build an access to subprogram whose designated type is
341 -- the type of the prefix. If prefix is overloaded, so it the
342 -- node itself. The result is stored in Acc_Type.
344 ------------------------------
345 -- Build_Access_Object_Type --
346 ------------------------------
348 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
352 if Aname = Name_Unrestricted_Access then
355 (E_Allocator_Type, Current_Scope, Loc, 'A');
359 (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
362 Set_Etype (Typ, Typ);
363 Init_Size_Align (Typ);
365 Set_Associated_Node_For_Itype (Typ, N);
366 Set_Directly_Designated_Type (Typ, DT);
368 end Build_Access_Object_Type;
370 ----------------------------------
371 -- Build_Access_Subprogram_Type --
372 ----------------------------------
374 procedure Build_Access_Subprogram_Type (P : Node_Id) is
375 Index : Interp_Index;
378 function Get_Kind (E : Entity_Id) return Entity_Kind;
379 -- Distinguish between access to regular and protected
386 function Get_Kind (E : Entity_Id) return Entity_Kind is
388 if Convention (E) = Convention_Protected then
389 return E_Access_Protected_Subprogram_Type;
391 return E_Access_Subprogram_Type;
395 -- Start of processing for Build_Access_Subprogram_Type
398 -- In the case of an access to subprogram, use the name of the
399 -- subprogram itself as the designated type. Type-checking in
400 -- this case compares the signatures of the designated types.
402 if not Is_Overloaded (P) then
405 (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
406 Set_Etype (Acc_Type, Acc_Type);
407 Set_Directly_Designated_Type (Acc_Type, Entity (P));
408 Set_Etype (N, Acc_Type);
411 Get_First_Interp (P, Index, It);
412 Set_Etype (N, Any_Type);
414 while Present (It.Nam) loop
415 if not Is_Intrinsic_Subprogram (It.Nam) then
418 (Get_Kind (It.Nam), Current_Scope, Loc, 'A');
419 Set_Etype (Acc_Type, Acc_Type);
420 Set_Directly_Designated_Type (Acc_Type, It.Nam);
421 Add_One_Interp (N, Acc_Type, Acc_Type);
424 Get_Next_Interp (Index, It);
427 if Etype (N) = Any_Type then
428 Error_Attr ("prefix of % attribute cannot be intrinsic", P);
431 end Build_Access_Subprogram_Type;
433 -- Start of processing for Analyze_Access_Attribute
438 if Nkind (P) = N_Character_Literal then
440 ("prefix of % attribute cannot be enumeration literal", P);
443 -- Case of access to subprogram
445 if Is_Entity_Name (P)
446 and then Is_Overloadable (Entity (P))
448 -- Not allowed for nested subprograms if No_Implicit_Dynamic_Code
449 -- restriction set (since in general a trampoline is required).
451 if not Is_Library_Level_Entity (Entity (P)) then
452 Check_Restriction (No_Implicit_Dynamic_Code, P);
455 -- Build the appropriate subprogram type
457 Build_Access_Subprogram_Type (P);
459 -- For unrestricted access, kill current values, since this
460 -- attribute allows a reference to a local subprogram that
461 -- could modify local variables to be passed out of scope
463 if Aname = Name_Unrestricted_Access then
469 -- Component is an operation of a protected type
471 elsif Nkind (P) = N_Selected_Component
472 and then Is_Overloadable (Entity (Selector_Name (P)))
474 if Ekind (Entity (Selector_Name (P))) = E_Entry then
475 Error_Attr ("prefix of % attribute must be subprogram", P);
478 Build_Access_Subprogram_Type (Selector_Name (P));
482 -- Deal with incorrect reference to a type, but note that some
483 -- accesses are allowed (references to the current type instance).
485 if Is_Entity_Name (P) then
486 Scop := Current_Scope;
489 if Is_Type (Typ) then
491 -- OK if we are within the scope of a limited type
492 -- let's mark the component as having per object constraint
494 if Is_Anonymous_Tagged_Base (Scop, Typ) then
502 Q : Node_Id := Parent (N);
506 and then Nkind (Q) /= N_Component_Declaration
511 Set_Has_Per_Object_Constraint (
512 Defining_Identifier (Q), True);
516 if Nkind (P) = N_Expanded_Name then
518 ("current instance prefix must be a direct name", P);
521 -- If a current instance attribute appears within a
522 -- a component constraint it must appear alone; other
523 -- contexts (default expressions, within a task body)
524 -- are not subject to this restriction.
526 if not In_Default_Expression
527 and then not Has_Completion (Scop)
529 Nkind (Parent (N)) /= N_Discriminant_Association
531 Nkind (Parent (N)) /= N_Index_Or_Discriminant_Constraint
534 ("current instance attribute must appear alone", N);
537 -- OK if we are in initialization procedure for the type
538 -- in question, in which case the reference to the type
539 -- is rewritten as a reference to the current object.
541 elsif Ekind (Scop) = E_Procedure
542 and then Is_Init_Proc (Scop)
543 and then Etype (First_Formal (Scop)) = Typ
546 Make_Attribute_Reference (Loc,
547 Prefix => Make_Identifier (Loc, Name_uInit),
548 Attribute_Name => Name_Unrestricted_Access));
552 -- OK if a task type, this test needs sharpening up ???
554 elsif Is_Task_Type (Typ) then
557 -- Otherwise we have an error case
560 Error_Attr ("% attribute cannot be applied to type", P);
566 -- If we fall through, we have a normal access to object case.
567 -- Unrestricted_Access is legal wherever an allocator would be
568 -- legal, so its Etype is set to E_Allocator. The expected type
569 -- of the other attributes is a general access type, and therefore
570 -- we label them with E_Access_Attribute_Type.
572 if not Is_Overloaded (P) then
573 Acc_Type := Build_Access_Object_Type (P_Type);
574 Set_Etype (N, Acc_Type);
577 Index : Interp_Index;
581 Set_Etype (N, Any_Type);
582 Get_First_Interp (P, Index, It);
584 while Present (It.Typ) loop
585 Acc_Type := Build_Access_Object_Type (It.Typ);
586 Add_One_Interp (N, Acc_Type, Acc_Type);
587 Get_Next_Interp (Index, It);
592 -- If we have an access to an object, and the attribute comes
593 -- from source, then set the object as potentially source modified.
594 -- We do this because the resulting access pointer can be used to
595 -- modify the variable, and we might not detect this, leading to
596 -- some junk warnings.
598 if Is_Entity_Name (P) then
599 Set_Never_Set_In_Source (Entity (P), False);
602 -- Check for aliased view unless unrestricted case. We allow
603 -- a nonaliased prefix when within an instance because the
604 -- prefix may have been a tagged formal object, which is
605 -- defined to be aliased even when the actual might not be
606 -- (other instance cases will have been caught in the generic).
608 if Aname /= Name_Unrestricted_Access
609 and then not Is_Aliased_View (P)
610 and then not In_Instance
612 Error_Attr ("prefix of % attribute must be aliased", P);
614 end Analyze_Access_Attribute;
616 --------------------------------
617 -- Check_Array_Or_Scalar_Type --
618 --------------------------------
620 procedure Check_Array_Or_Scalar_Type is
624 -- Dimension number for array attributes.
627 -- Case of string literal or string literal subtype. These cases
628 -- cannot arise from legal Ada code, but the expander is allowed
629 -- to generate them. They require special handling because string
630 -- literal subtypes do not have standard bounds (the whole idea
631 -- of these subtypes is to avoid having to generate the bounds)
633 if Ekind (P_Type) = E_String_Literal_Subtype then
634 Set_Etype (N, Etype (First_Index (P_Base_Type)));
639 elsif Is_Scalar_Type (P_Type) then
643 Error_Attr ("invalid argument in % attribute", E1);
645 Set_Etype (N, P_Base_Type);
649 -- The following is a special test to allow 'First to apply to
650 -- private scalar types if the attribute comes from generated
651 -- code. This occurs in the case of Normalize_Scalars code.
653 elsif Is_Private_Type (P_Type)
654 and then Present (Full_View (P_Type))
655 and then Is_Scalar_Type (Full_View (P_Type))
656 and then not Comes_From_Source (N)
658 Set_Etype (N, Implementation_Base_Type (P_Type));
660 -- Array types other than string literal subtypes handled above
665 -- We know prefix is an array type, or the name of an array
666 -- object, and that the expression, if present, is static
667 -- and within the range of the dimensions of the type.
669 if Is_Array_Type (P_Type) then
670 Index := First_Index (P_Base_Type);
672 else pragma Assert (Is_Access_Type (P_Type));
673 Index := First_Index (Base_Type (Designated_Type (P_Type)));
678 -- First dimension assumed
680 Set_Etype (N, Base_Type (Etype (Index)));
683 D := UI_To_Int (Intval (E1));
685 for J in 1 .. D - 1 loop
689 Set_Etype (N, Base_Type (Etype (Index)));
690 Set_Etype (E1, Standard_Integer);
693 end Check_Array_Or_Scalar_Type;
695 ----------------------
696 -- Check_Array_Type --
697 ----------------------
699 procedure Check_Array_Type is
701 -- Dimension number for array attributes.
704 -- If the type is a string literal type, then this must be generated
705 -- internally, and no further check is required on its legality.
707 if Ekind (P_Type) = E_String_Literal_Subtype then
710 -- If the type is a composite, it is an illegal aggregate, no point
713 elsif P_Type = Any_Composite then
717 -- Normal case of array type or subtype
719 Check_Either_E0_Or_E1;
721 if Is_Array_Type (P_Type) then
722 if not Is_Constrained (P_Type)
723 and then Is_Entity_Name (P)
724 and then Is_Type (Entity (P))
726 -- Note: we do not call Error_Attr here, since we prefer to
727 -- continue, using the relevant index type of the array,
728 -- even though it is unconstrained. This gives better error
729 -- recovery behavior.
731 Error_Msg_Name_1 := Aname;
733 ("prefix for % attribute must be constrained array", P);
736 D := Number_Dimensions (P_Type);
738 elsif Is_Access_Type (P_Type)
739 and then Is_Array_Type (Designated_Type (P_Type))
741 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
742 Error_Attr ("prefix of % attribute cannot be access type", P);
745 D := Number_Dimensions (Designated_Type (P_Type));
747 -- If there is an implicit dereference, then we must freeze
748 -- the designated type of the access type, since the type of
749 -- the referenced array is this type (see AI95-00106).
751 Freeze_Before (N, Designated_Type (P_Type));
754 if Is_Private_Type (P_Type) then
756 ("prefix for % attribute may not be private type", P);
758 elsif Attr_Id = Attribute_First
760 Attr_Id = Attribute_Last
762 Error_Attr ("invalid prefix for % attribute", P);
765 Error_Attr ("prefix for % attribute must be array", P);
770 Resolve (E1, Any_Integer);
771 Set_Etype (E1, Standard_Integer);
773 if not Is_Static_Expression (E1)
774 or else Raises_Constraint_Error (E1)
777 ("expression for dimension must be static!", E1);
780 elsif UI_To_Int (Expr_Value (E1)) > D
781 or else UI_To_Int (Expr_Value (E1)) < 1
783 Error_Attr ("invalid dimension number for array type", E1);
786 end Check_Array_Type;
788 -------------------------
789 -- Check_Asm_Attribute --
790 -------------------------
792 procedure Check_Asm_Attribute is
797 -- Check first argument is static string expression
799 Analyze_And_Resolve (E1, Standard_String);
801 if Etype (E1) = Any_Type then
804 elsif not Is_OK_Static_Expression (E1) then
806 ("constraint argument must be static string expression!", E1);
810 -- Check second argument is right type
812 Analyze_And_Resolve (E2, Entity (P));
814 -- Note: that is all we need to do, we don't need to check
815 -- that it appears in a correct context. The Ada type system
816 -- will do that for us.
818 end Check_Asm_Attribute;
820 ---------------------
821 -- Check_Component --
822 ---------------------
824 procedure Check_Component is
828 if Nkind (P) /= N_Selected_Component
830 (Ekind (Entity (Selector_Name (P))) /= E_Component
832 Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
835 ("prefix for % attribute must be selected component", P);
839 ------------------------------------
840 -- Check_Decimal_Fixed_Point_Type --
841 ------------------------------------
843 procedure Check_Decimal_Fixed_Point_Type is
847 if not Is_Decimal_Fixed_Point_Type (P_Type) then
849 ("prefix of % attribute must be decimal type", P);
851 end Check_Decimal_Fixed_Point_Type;
853 -----------------------
854 -- Check_Dereference --
855 -----------------------
857 procedure Check_Dereference is
859 if Is_Object_Reference (P)
860 and then Is_Access_Type (P_Type)
863 Make_Explicit_Dereference (Sloc (P),
864 Prefix => Relocate_Node (P)));
866 Analyze_And_Resolve (P);
869 if P_Type = Any_Type then
873 P_Base_Type := Base_Type (P_Type);
875 end Check_Dereference;
877 -------------------------
878 -- Check_Discrete_Type --
879 -------------------------
881 procedure Check_Discrete_Type is
885 if not Is_Discrete_Type (P_Type) then
886 Error_Attr ("prefix of % attribute must be discrete type", P);
888 end Check_Discrete_Type;
894 procedure Check_E0 is
897 Unexpected_Argument (E1);
905 procedure Check_E1 is
907 Check_Either_E0_Or_E1;
911 -- Special-case attributes that are functions and that appear as
912 -- the prefix of another attribute. Error is posted on parent.
914 if Nkind (Parent (N)) = N_Attribute_Reference
915 and then (Attribute_Name (Parent (N)) = Name_Address
917 Attribute_Name (Parent (N)) = Name_Code_Address
919 Attribute_Name (Parent (N)) = Name_Access)
921 Error_Msg_Name_1 := Attribute_Name (Parent (N));
922 Error_Msg_N ("illegal prefix for % attribute", Parent (N));
923 Set_Etype (Parent (N), Any_Type);
924 Set_Entity (Parent (N), Any_Type);
928 Error_Attr ("missing argument for % attribute", N);
937 procedure Check_E2 is
940 Error_Attr ("missing arguments for % attribute (2 required)", N);
942 Error_Attr ("missing argument for % attribute (2 required)", N);
946 ---------------------------
947 -- Check_Either_E0_Or_E1 --
948 ---------------------------
950 procedure Check_Either_E0_Or_E1 is
953 Unexpected_Argument (E2);
955 end Check_Either_E0_Or_E1;
957 ----------------------
958 -- Check_Enum_Image --
959 ----------------------
961 procedure Check_Enum_Image is
965 if Is_Enumeration_Type (P_Base_Type) then
966 Lit := First_Literal (P_Base_Type);
967 while Present (Lit) loop
968 Set_Referenced (Lit);
972 end Check_Enum_Image;
974 ----------------------------
975 -- Check_Fixed_Point_Type --
976 ----------------------------
978 procedure Check_Fixed_Point_Type is
982 if not Is_Fixed_Point_Type (P_Type) then
983 Error_Attr ("prefix of % attribute must be fixed point type", P);
985 end Check_Fixed_Point_Type;
987 ------------------------------
988 -- Check_Fixed_Point_Type_0 --
989 ------------------------------
991 procedure Check_Fixed_Point_Type_0 is
993 Check_Fixed_Point_Type;
995 end Check_Fixed_Point_Type_0;
997 -------------------------------
998 -- Check_Floating_Point_Type --
999 -------------------------------
1001 procedure Check_Floating_Point_Type is
1005 if not Is_Floating_Point_Type (P_Type) then
1006 Error_Attr ("prefix of % attribute must be float type", P);
1008 end Check_Floating_Point_Type;
1010 ---------------------------------
1011 -- Check_Floating_Point_Type_0 --
1012 ---------------------------------
1014 procedure Check_Floating_Point_Type_0 is
1016 Check_Floating_Point_Type;
1018 end Check_Floating_Point_Type_0;
1020 ---------------------------------
1021 -- Check_Floating_Point_Type_1 --
1022 ---------------------------------
1024 procedure Check_Floating_Point_Type_1 is
1026 Check_Floating_Point_Type;
1028 end Check_Floating_Point_Type_1;
1030 ---------------------------------
1031 -- Check_Floating_Point_Type_2 --
1032 ---------------------------------
1034 procedure Check_Floating_Point_Type_2 is
1036 Check_Floating_Point_Type;
1038 end Check_Floating_Point_Type_2;
1040 ------------------------
1041 -- Check_Integer_Type --
1042 ------------------------
1044 procedure Check_Integer_Type is
1048 if not Is_Integer_Type (P_Type) then
1049 Error_Attr ("prefix of % attribute must be integer type", P);
1051 end Check_Integer_Type;
1053 ------------------------
1054 -- Check_Library_Unit --
1055 ------------------------
1057 procedure Check_Library_Unit is
1059 if not Is_Compilation_Unit (Entity (P)) then
1060 Error_Attr ("prefix of % attribute must be library unit", P);
1062 end Check_Library_Unit;
1064 -------------------------------
1065 -- Check_Not_Incomplete_Type --
1066 -------------------------------
1068 procedure Check_Not_Incomplete_Type is
1070 if not Is_Entity_Name (P)
1071 or else not Is_Type (Entity (P))
1072 or else In_Default_Expression
1077 Check_Fully_Declared (P_Type, P);
1079 end Check_Not_Incomplete_Type;
1081 ----------------------------
1082 -- Check_Object_Reference --
1083 ----------------------------
1085 procedure Check_Object_Reference (P : Node_Id) is
1089 -- If we need an object, and we have a prefix that is the name of
1090 -- a function entity, convert it into a function call.
1092 if Is_Entity_Name (P)
1093 and then Ekind (Entity (P)) = E_Function
1095 Rtyp := Etype (Entity (P));
1098 Make_Function_Call (Sloc (P),
1099 Name => Relocate_Node (P)));
1101 Analyze_And_Resolve (P, Rtyp);
1103 -- Otherwise we must have an object reference
1105 elsif not Is_Object_Reference (P) then
1106 Error_Attr ("prefix of % attribute must be object", P);
1108 end Check_Object_Reference;
1110 ------------------------
1111 -- Check_Program_Unit --
1112 ------------------------
1114 procedure Check_Program_Unit is
1116 if Is_Entity_Name (P) then
1118 K : constant Entity_Kind := Ekind (Entity (P));
1119 T : constant Entity_Id := Etype (Entity (P));
1122 if K in Subprogram_Kind
1123 or else K in Task_Kind
1124 or else K in Protected_Kind
1125 or else K = E_Package
1126 or else K in Generic_Unit_Kind
1127 or else (K = E_Variable
1131 Is_Protected_Type (T)))
1138 Error_Attr ("prefix of % attribute must be program unit", P);
1139 end Check_Program_Unit;
1141 ---------------------
1142 -- Check_Real_Type --
1143 ---------------------
1145 procedure Check_Real_Type is
1149 if not Is_Real_Type (P_Type) then
1150 Error_Attr ("prefix of % attribute must be real type", P);
1152 end Check_Real_Type;
1154 -----------------------
1155 -- Check_Scalar_Type --
1156 -----------------------
1158 procedure Check_Scalar_Type is
1162 if not Is_Scalar_Type (P_Type) then
1163 Error_Attr ("prefix of % attribute must be scalar type", P);
1165 end Check_Scalar_Type;
1167 ---------------------------
1168 -- Check_Standard_Prefix --
1169 ---------------------------
1171 procedure Check_Standard_Prefix is
1175 if Nkind (P) /= N_Identifier
1176 or else Chars (P) /= Name_Standard
1178 Error_Attr ("only allowed prefix for % attribute is Standard", P);
1181 end Check_Standard_Prefix;
1183 ----------------------------
1184 -- Check_Stream_Attribute --
1185 ----------------------------
1187 procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
1192 Validate_Non_Static_Attribute_Function_Call;
1194 -- With the exception of 'Input, Stream attributes are procedures,
1195 -- and can only appear at the position of procedure calls. We check
1196 -- for this here, before they are rewritten, to give a more precise
1199 if Nam = TSS_Stream_Input then
1202 elsif Is_List_Member (N)
1203 and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
1204 and then Nkind (Parent (N)) /= N_Aggregate
1210 ("invalid context for attribute%, which is a procedure", N);
1214 Btyp := Implementation_Base_Type (P_Type);
1216 -- Stream attributes not allowed on limited types unless the
1217 -- special OK_For_Stream flag is set.
1219 if Is_Limited_Type (P_Type)
1220 and then Comes_From_Source (N)
1221 and then not Present (TSS (Btyp, Nam))
1222 and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert))
1224 Error_Msg_Name_1 := Aname;
1226 ("limited type& has no% attribute", P, Btyp);
1227 Explain_Limited_Type (P_Type, P);
1230 -- Check for violation of restriction No_Stream_Attributes
1232 if Is_RTE (P_Type, RE_Exception_Id)
1234 Is_RTE (P_Type, RE_Exception_Occurrence)
1236 Check_Restriction (No_Exception_Registration, P);
1239 -- Here we must check that the first argument is an access type
1240 -- that is compatible with Ada.Streams.Root_Stream_Type'Class.
1242 Analyze_And_Resolve (E1);
1245 -- Note: the double call to Root_Type here is needed because the
1246 -- root type of a class-wide type is the corresponding type (e.g.
1247 -- X for X'Class, and we really want to go to the root.
1249 if not Is_Access_Type (Etyp)
1250 or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
1251 RTE (RE_Root_Stream_Type)
1254 ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
1257 -- Check that the second argument is of the right type if there is
1258 -- one (the Input attribute has only one argument so this is skipped)
1260 if Present (E2) then
1263 if Nam = TSS_Stream_Read
1264 and then not Is_OK_Variable_For_Out_Formal (E2)
1267 ("second argument of % attribute must be a variable", E2);
1270 Resolve (E2, P_Type);
1272 end Check_Stream_Attribute;
1274 -----------------------
1275 -- Check_Task_Prefix --
1276 -----------------------
1278 procedure Check_Task_Prefix is
1282 if Is_Task_Type (Etype (P))
1283 or else (Is_Access_Type (Etype (P))
1284 and then Is_Task_Type (Designated_Type (Etype (P))))
1288 Error_Attr ("prefix of % attribute must be a task", P);
1290 end Check_Task_Prefix;
1296 -- The possibilities are an entity name denoting a type, or an
1297 -- attribute reference that denotes a type (Base or Class). If
1298 -- the type is incomplete, replace it with its full view.
1300 procedure Check_Type is
1302 if not Is_Entity_Name (P)
1303 or else not Is_Type (Entity (P))
1305 Error_Attr ("prefix of % attribute must be a type", P);
1307 elsif Ekind (Entity (P)) = E_Incomplete_Type
1308 and then Present (Full_View (Entity (P)))
1310 P_Type := Full_View (Entity (P));
1311 Set_Entity (P, P_Type);
1315 ---------------------
1316 -- Check_Unit_Name --
1317 ---------------------
1319 procedure Check_Unit_Name (Nod : Node_Id) is
1321 if Nkind (Nod) = N_Identifier then
1324 elsif Nkind (Nod) = N_Selected_Component then
1325 Check_Unit_Name (Prefix (Nod));
1327 if Nkind (Selector_Name (Nod)) = N_Identifier then
1332 Error_Attr ("argument for % attribute must be unit name", P);
1333 end Check_Unit_Name;
1339 procedure Error_Attr is
1341 Set_Etype (N, Any_Type);
1342 Set_Entity (N, Any_Type);
1343 raise Bad_Attribute;
1346 procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
1348 Error_Msg_Name_1 := Aname;
1349 Error_Msg_N (Msg, Error_Node);
1353 ----------------------------
1354 -- Legal_Formal_Attribute --
1355 ----------------------------
1357 procedure Legal_Formal_Attribute is
1361 if not Is_Entity_Name (P)
1362 or else not Is_Type (Entity (P))
1364 Error_Attr ("prefix of % attribute must be generic type", N);
1366 elsif Is_Generic_Actual_Type (Entity (P))
1368 or else In_Inlined_Body
1372 elsif Is_Generic_Type (Entity (P)) then
1373 if not Is_Indefinite_Subtype (Entity (P)) then
1375 ("prefix of % attribute must be indefinite generic type", N);
1380 ("prefix of % attribute must be indefinite generic type", N);
1383 Set_Etype (N, Standard_Boolean);
1384 end Legal_Formal_Attribute;
1386 ------------------------
1387 -- Standard_Attribute --
1388 ------------------------
1390 procedure Standard_Attribute (Val : Int) is
1392 Check_Standard_Prefix;
1394 -- First a special check (more like a kludge really). For GNAT5
1395 -- on Windows, the alignments in GCC are severely mixed up. In
1396 -- particular, we have a situation where the maximum alignment
1397 -- that GCC thinks is possible is greater than the guaranteed
1398 -- alignment at run-time. That causes many problems. As a partial
1399 -- cure for this situation, we force a value of 4 for the maximum
1400 -- alignment attribute on this target. This still does not solve
1401 -- all problems, but it helps.
1403 -- A further (even more horrible) dimension to this kludge is now
1404 -- installed. There are two uses for Maximum_Alignment, one is to
1405 -- determine the maximum guaranteed alignment, that's the one we
1406 -- want the kludge to yield as 4. The other use is to maximally
1407 -- align objects, we can't use 4 here, since for example, long
1408 -- long integer has an alignment of 8, so we will get errors.
1410 -- It is of course impossible to determine which use the programmer
1411 -- has in mind, but an approximation for now is to disconnect the
1412 -- kludge if the attribute appears in an alignment clause.
1414 -- To be removed if GCC ever gets its act together here ???
1416 Alignment_Kludge : declare
1419 function On_X86 return Boolean;
1420 -- Determine if target is x86 (ia32), return True if so
1426 function On_X86 return Boolean is
1427 T : constant String := Sdefault.Target_Name.all;
1430 -- There is no clean way to check this. That's not surprising,
1431 -- the front end should not be doing this kind of test ???. The
1432 -- way we do it is test for either "86" or "pentium" being in
1433 -- the string for the target name.
1435 for J in T'First .. T'Last - 1 loop
1436 if T (J .. J + 1) = "86"
1437 or else (J <= T'Last - 6
1438 and then T (J .. J + 6) = "pentium")
1448 if Aname = Name_Maximum_Alignment and then On_X86 then
1451 while Nkind (P) in N_Subexpr loop
1455 if Nkind (P) /= N_Attribute_Definition_Clause
1456 or else Chars (P) /= Name_Alignment
1458 Rewrite (N, Make_Integer_Literal (Loc, 4));
1463 end Alignment_Kludge;
1465 -- Normally we get the value from gcc ???
1467 Rewrite (N, Make_Integer_Literal (Loc, Val));
1469 end Standard_Attribute;
1471 -------------------------
1472 -- Unexpected Argument --
1473 -------------------------
1475 procedure Unexpected_Argument (En : Node_Id) is
1477 Error_Attr ("unexpected argument for % attribute", En);
1478 end Unexpected_Argument;
1480 -------------------------------------------------
1481 -- Validate_Non_Static_Attribute_Function_Call --
1482 -------------------------------------------------
1484 -- This function should be moved to Sem_Dist ???
1486 procedure Validate_Non_Static_Attribute_Function_Call is
1488 if In_Preelaborated_Unit
1489 and then not In_Subprogram_Or_Concurrent_Unit
1491 Flag_Non_Static_Expr
1492 ("non-static function call in preelaborated unit!", N);
1494 end Validate_Non_Static_Attribute_Function_Call;
1496 -----------------------------------------------
1497 -- Start of Processing for Analyze_Attribute --
1498 -----------------------------------------------
1501 -- Immediate return if unrecognized attribute (already diagnosed
1502 -- by parser, so there is nothing more that we need to do)
1504 if not Is_Attribute_Name (Aname) then
1505 raise Bad_Attribute;
1508 -- Deal with Ada 83 and Features issues
1510 if Comes_From_Source (N) then
1511 if not Attribute_83 (Attr_Id) then
1512 if Ada_83 and then Comes_From_Source (N) then
1513 Error_Msg_Name_1 := Aname;
1514 Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
1517 if Attribute_Impl_Def (Attr_Id) then
1518 Check_Restriction (No_Implementation_Attributes, N);
1523 -- Remote access to subprogram type access attribute reference needs
1524 -- unanalyzed copy for tree transformation. The analyzed copy is used
1525 -- for its semantic information (whether prefix is a remote subprogram
1526 -- name), the unanalyzed copy is used to construct new subtree rooted
1527 -- with N_aggregate which represents a fat pointer aggregate.
1529 if Aname = Name_Access then
1530 Discard_Node (Copy_Separate_Tree (N));
1533 -- Analyze prefix and exit if error in analysis. If the prefix is an
1534 -- incomplete type, use full view if available. A special case is
1535 -- that we never analyze the prefix of an Elab_Body or Elab_Spec
1536 -- or UET_Address attribute.
1538 if Aname /= Name_Elab_Body
1540 Aname /= Name_Elab_Spec
1542 Aname /= Name_UET_Address
1545 P_Type := Etype (P);
1547 if Is_Entity_Name (P)
1548 and then Present (Entity (P))
1549 and then Is_Type (Entity (P))
1550 and then Ekind (Entity (P)) = E_Incomplete_Type
1552 P_Type := Get_Full_View (P_Type);
1553 Set_Entity (P, P_Type);
1554 Set_Etype (P, P_Type);
1557 if P_Type = Any_Type then
1558 raise Bad_Attribute;
1561 P_Base_Type := Base_Type (P_Type);
1564 -- Analyze expressions that may be present, exiting if an error occurs
1571 E1 := First (Exprs);
1574 -- Check for missing or bad expression (result of previous error)
1576 if No (E1) or else Etype (E1) = Any_Type then
1577 raise Bad_Attribute;
1582 if Present (E2) then
1585 if Etype (E2) = Any_Type then
1586 raise Bad_Attribute;
1589 if Present (Next (E2)) then
1590 Unexpected_Argument (Next (E2));
1595 if Is_Overloaded (P)
1596 and then Aname /= Name_Access
1597 and then Aname /= Name_Address
1598 and then Aname /= Name_Code_Address
1599 and then Aname /= Name_Count
1600 and then Aname /= Name_Unchecked_Access
1602 Error_Attr ("ambiguous prefix for % attribute", P);
1605 -- Remaining processing depends on attribute
1613 when Attribute_Abort_Signal =>
1614 Check_Standard_Prefix;
1616 New_Reference_To (Stand.Abort_Signal, Loc));
1623 when Attribute_Access =>
1624 Analyze_Access_Attribute;
1630 when Attribute_Address =>
1633 -- Check for some junk cases, where we have to allow the address
1634 -- attribute but it does not make much sense, so at least for now
1635 -- just replace with Null_Address.
1637 -- We also do this if the prefix is a reference to the AST_Entry
1638 -- attribute. If expansion is active, the attribute will be
1639 -- replaced by a function call, and address will work fine and
1640 -- get the proper value, but if expansion is not active, then
1641 -- the check here allows proper semantic analysis of the reference.
1643 -- An Address attribute created by expansion is legal even when it
1644 -- applies to other entity-denoting expressions.
1646 if Is_Entity_Name (P) then
1648 Ent : constant Entity_Id := Entity (P);
1651 if Is_Subprogram (Ent) then
1652 if not Is_Library_Level_Entity (Ent) then
1653 Check_Restriction (No_Implicit_Dynamic_Code, P);
1656 Set_Address_Taken (Ent);
1658 elsif Is_Object (Ent)
1659 or else Ekind (Ent) = E_Label
1661 Set_Address_Taken (Ent);
1663 -- If we have an address of an object, and the attribute
1664 -- comes from source, then set the object as potentially
1665 -- source modified. We do this because the resulting address
1666 -- can potentially be used to modify the variable and we
1667 -- might not detect this, leading to some junk warnings.
1669 Set_Never_Set_In_Source (Ent, False);
1671 elsif (Is_Concurrent_Type (Etype (Ent))
1672 and then Etype (Ent) = Base_Type (Ent))
1673 or else Ekind (Ent) = E_Package
1674 or else Is_Generic_Unit (Ent)
1677 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
1680 Error_Attr ("invalid prefix for % attribute", P);
1684 elsif Nkind (P) = N_Attribute_Reference
1685 and then Attribute_Name (P) = Name_AST_Entry
1688 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
1690 elsif Is_Object_Reference (P) then
1693 elsif Nkind (P) = N_Selected_Component
1694 and then Is_Subprogram (Entity (Selector_Name (P)))
1698 -- What exactly are we allowing here ??? and is this properly
1699 -- documented in the sinfo documentation for this node ???
1701 elsif not Comes_From_Source (N) then
1705 Error_Attr ("invalid prefix for % attribute", P);
1708 Set_Etype (N, RTE (RE_Address));
1714 when Attribute_Address_Size =>
1715 Standard_Attribute (System_Address_Size);
1721 when Attribute_Adjacent =>
1722 Check_Floating_Point_Type_2;
1723 Set_Etype (N, P_Base_Type);
1724 Resolve (E1, P_Base_Type);
1725 Resolve (E2, P_Base_Type);
1731 when Attribute_Aft =>
1732 Check_Fixed_Point_Type_0;
1733 Set_Etype (N, Universal_Integer);
1739 when Attribute_Alignment =>
1741 -- Don't we need more checking here, cf Size ???
1744 Check_Not_Incomplete_Type;
1745 Set_Etype (N, Universal_Integer);
1751 when Attribute_Asm_Input =>
1752 Check_Asm_Attribute;
1753 Set_Etype (N, RTE (RE_Asm_Input_Operand));
1759 when Attribute_Asm_Output =>
1760 Check_Asm_Attribute;
1762 if Etype (E2) = Any_Type then
1765 elsif Aname = Name_Asm_Output then
1766 if not Is_Variable (E2) then
1768 ("second argument for Asm_Output is not variable", E2);
1772 Note_Possible_Modification (E2);
1773 Set_Etype (N, RTE (RE_Asm_Output_Operand));
1779 when Attribute_AST_Entry => AST_Entry : declare
1785 -- Indicates if entry family index is present. Note the coding
1786 -- here handles the entry family case, but in fact it cannot be
1787 -- executed currently, because pragma AST_Entry does not permit
1788 -- the specification of an entry family.
1790 procedure Bad_AST_Entry;
1791 -- Signal a bad AST_Entry pragma
1793 function OK_Entry (E : Entity_Id) return Boolean;
1794 -- Checks that E is of an appropriate entity kind for an entry
1795 -- (i.e. E_Entry if Index is False, or E_Entry_Family if Index
1796 -- is set True for the entry family case). In the True case,
1797 -- makes sure that Is_AST_Entry is set on the entry.
1799 procedure Bad_AST_Entry is
1801 Error_Attr ("prefix for % attribute must be task entry", P);
1804 function OK_Entry (E : Entity_Id) return Boolean is
1809 Result := (Ekind (E) = E_Entry_Family);
1811 Result := (Ekind (E) = E_Entry);
1815 if not Is_AST_Entry (E) then
1816 Error_Msg_Name_2 := Aname;
1818 ("% attribute requires previous % pragma", P);
1825 -- Start of processing for AST_Entry
1831 -- Deal with entry family case
1833 if Nkind (P) = N_Indexed_Component then
1841 Ptyp := Etype (Pref);
1843 if Ptyp = Any_Type or else Error_Posted (Pref) then
1847 -- If the prefix is a selected component whose prefix is of an
1848 -- access type, then introduce an explicit dereference.
1850 if Nkind (Pref) = N_Selected_Component
1851 and then Is_Access_Type (Ptyp)
1854 Make_Explicit_Dereference (Sloc (Pref),
1855 Relocate_Node (Pref)));
1856 Analyze_And_Resolve (Pref, Designated_Type (Ptyp));
1859 -- Prefix can be of the form a.b, where a is a task object
1860 -- and b is one of the entries of the corresponding task type.
1862 if Nkind (Pref) = N_Selected_Component
1863 and then OK_Entry (Entity (Selector_Name (Pref)))
1864 and then Is_Object_Reference (Prefix (Pref))
1865 and then Is_Task_Type (Etype (Prefix (Pref)))
1869 -- Otherwise the prefix must be an entry of a containing task,
1870 -- or of a variable of the enclosing task type.
1873 if Nkind (Pref) = N_Identifier
1874 or else Nkind (Pref) = N_Expanded_Name
1876 Ent := Entity (Pref);
1878 if not OK_Entry (Ent)
1879 or else not In_Open_Scopes (Scope (Ent))
1889 Set_Etype (N, RTE (RE_AST_Handler));
1896 -- Note: when the base attribute appears in the context of a subtype
1897 -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
1898 -- the following circuit.
1900 when Attribute_Base => Base : declare
1904 Check_Either_E0_Or_E1;
1909 and then not Is_Scalar_Type (Typ)
1910 and then not Is_Generic_Type (Typ)
1912 Error_Msg_N ("prefix of Base attribute must be scalar type", N);
1914 elsif Sloc (Typ) = Standard_Location
1915 and then Base_Type (Typ) = Typ
1916 and then Warn_On_Redundant_Constructs
1919 ("?redudant attribute, & is its own base type", N, Typ);
1922 Set_Etype (N, Base_Type (Entity (P)));
1924 -- If we have an expression present, then really this is a conversion
1925 -- and the tree must be reformed. Note that this is one of the cases
1926 -- in which we do a replace rather than a rewrite, because the
1927 -- original tree is junk.
1929 if Present (E1) then
1931 Make_Type_Conversion (Loc,
1933 Make_Attribute_Reference (Loc,
1934 Prefix => Prefix (N),
1935 Attribute_Name => Name_Base),
1936 Expression => Relocate_Node (E1)));
1938 -- E1 may be overloaded, and its interpretations preserved.
1940 Save_Interps (E1, Expression (N));
1943 -- For other cases, set the proper type as the entity of the
1944 -- attribute reference, and then rewrite the node to be an
1945 -- occurrence of the referenced base type. This way, no one
1946 -- else in the compiler has to worry about the base attribute.
1949 Set_Entity (N, Base_Type (Entity (P)));
1951 New_Reference_To (Entity (N), Loc));
1960 when Attribute_Bit => Bit :
1964 if not Is_Object_Reference (P) then
1965 Error_Attr ("prefix for % attribute must be object", P);
1967 -- What about the access object cases ???
1973 Set_Etype (N, Universal_Integer);
1980 when Attribute_Bit_Order => Bit_Order :
1985 if not Is_Record_Type (P_Type) then
1986 Error_Attr ("prefix of % attribute must be record type", P);
1989 if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
1991 New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
1994 New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
1997 Set_Etype (N, RTE (RE_Bit_Order));
2000 -- Reset incorrect indication of staticness
2002 Set_Is_Static_Expression (N, False);
2009 -- Note: in generated code, we can have a Bit_Position attribute
2010 -- applied to a (naked) record component (i.e. the prefix is an
2011 -- identifier that references an E_Component or E_Discriminant
2012 -- entity directly, and this is interpreted as expected by Gigi.
2013 -- The following code will not tolerate such usage, but when the
2014 -- expander creates this special case, it marks it as analyzed
2015 -- immediately and sets an appropriate type.
2017 when Attribute_Bit_Position =>
2019 if Comes_From_Source (N) then
2023 Set_Etype (N, Universal_Integer);
2029 when Attribute_Body_Version =>
2032 Set_Etype (N, RTE (RE_Version_String));
2038 when Attribute_Callable =>
2040 Set_Etype (N, Standard_Boolean);
2047 when Attribute_Caller => Caller : declare
2054 if Nkind (P) = N_Identifier
2055 or else Nkind (P) = N_Expanded_Name
2059 if not Is_Entry (Ent) then
2060 Error_Attr ("invalid entry name", N);
2064 Error_Attr ("invalid entry name", N);
2068 for J in reverse 0 .. Scope_Stack.Last loop
2069 S := Scope_Stack.Table (J).Entity;
2071 if S = Scope (Ent) then
2072 Error_Attr ("Caller must appear in matching accept or body", N);
2078 Set_Etype (N, RTE (RO_AT_Task_ID));
2085 when Attribute_Ceiling =>
2086 Check_Floating_Point_Type_1;
2087 Set_Etype (N, P_Base_Type);
2088 Resolve (E1, P_Base_Type);
2094 when Attribute_Class => Class : declare
2096 Check_Restriction (No_Dispatch, N);
2097 Check_Either_E0_Or_E1;
2099 -- If we have an expression present, then really this is a conversion
2100 -- and the tree must be reformed into a proper conversion. This is a
2101 -- Replace rather than a Rewrite, because the original tree is junk.
2102 -- If expression is overloaded, propagate interpretations to new one.
2104 if Present (E1) then
2106 Make_Type_Conversion (Loc,
2108 Make_Attribute_Reference (Loc,
2109 Prefix => Prefix (N),
2110 Attribute_Name => Name_Class),
2111 Expression => Relocate_Node (E1)));
2113 Save_Interps (E1, Expression (N));
2116 -- Otherwise we just need to find the proper type
2128 when Attribute_Code_Address =>
2131 if Nkind (P) = N_Attribute_Reference
2132 and then (Attribute_Name (P) = Name_Elab_Body
2134 Attribute_Name (P) = Name_Elab_Spec)
2138 elsif not Is_Entity_Name (P)
2139 or else (Ekind (Entity (P)) /= E_Function
2141 Ekind (Entity (P)) /= E_Procedure)
2143 Error_Attr ("invalid prefix for % attribute", P);
2144 Set_Address_Taken (Entity (P));
2147 Set_Etype (N, RTE (RE_Address));
2149 --------------------
2150 -- Component_Size --
2151 --------------------
2153 when Attribute_Component_Size =>
2155 Set_Etype (N, Universal_Integer);
2157 -- Note: unlike other array attributes, unconstrained arrays are OK
2159 if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
2169 when Attribute_Compose =>
2170 Check_Floating_Point_Type_2;
2171 Set_Etype (N, P_Base_Type);
2172 Resolve (E1, P_Base_Type);
2173 Resolve (E2, Any_Integer);
2179 when Attribute_Constrained =>
2181 Set_Etype (N, Standard_Boolean);
2183 -- Case from RM J.4(2) of constrained applied to private type
2185 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
2187 -- If we are within an instance, the attribute must be legal
2188 -- because it was valid in the generic unit. Ditto if this is
2189 -- an inlining of a function declared in an instance.
2192 or else In_Inlined_Body
2196 -- For sure OK if we have a real private type itself, but must
2197 -- be completed, cannot apply Constrained to incomplete type.
2199 elsif Is_Private_Type (Entity (P)) then
2201 -- Note: this is one of the Annex J features that does not
2202 -- generate a warning from -gnatwj, since in fact it seems
2203 -- very useful, and is used in the GNAT runtime.
2205 Check_Not_Incomplete_Type;
2209 -- Normal (non-obsolescent case) of application to object of
2210 -- a discriminated type.
2213 Check_Object_Reference (P);
2215 -- If N does not come from source, then we allow the
2216 -- the attribute prefix to be of a private type whose
2217 -- full type has discriminants. This occurs in cases
2218 -- involving expanded calls to stream attributes.
2220 if not Comes_From_Source (N) then
2221 P_Type := Underlying_Type (P_Type);
2224 -- Must have discriminants or be an access type designating
2225 -- a type with discriminants. If it is a classwide type is
2226 -- has unknown discriminants.
2228 if Has_Discriminants (P_Type)
2229 or else Has_Unknown_Discriminants (P_Type)
2231 (Is_Access_Type (P_Type)
2232 and then Has_Discriminants (Designated_Type (P_Type)))
2236 -- Also allow an object of a generic type if extensions allowed
2237 -- and allow this for any type at all.
2239 elsif (Is_Generic_Type (P_Type)
2240 or else Is_Generic_Actual_Type (P_Type))
2241 and then Extensions_Allowed
2247 -- Fall through if bad prefix
2250 ("prefix of % attribute must be object of discriminated type", P);
2256 when Attribute_Copy_Sign =>
2257 Check_Floating_Point_Type_2;
2258 Set_Etype (N, P_Base_Type);
2259 Resolve (E1, P_Base_Type);
2260 Resolve (E2, P_Base_Type);
2266 when Attribute_Count => Count :
2275 if Nkind (P) = N_Identifier
2276 or else Nkind (P) = N_Expanded_Name
2280 if Ekind (Ent) /= E_Entry then
2281 Error_Attr ("invalid entry name", N);
2284 elsif Nkind (P) = N_Indexed_Component then
2285 if not Is_Entity_Name (Prefix (P))
2286 or else No (Entity (Prefix (P)))
2287 or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
2289 if Nkind (Prefix (P)) = N_Selected_Component
2290 and then Present (Entity (Selector_Name (Prefix (P))))
2291 and then Ekind (Entity (Selector_Name (Prefix (P)))) =
2295 ("attribute % must apply to entry of current task", P);
2298 Error_Attr ("invalid entry family name", P);
2303 Ent := Entity (Prefix (P));
2306 elsif Nkind (P) = N_Selected_Component
2307 and then Present (Entity (Selector_Name (P)))
2308 and then Ekind (Entity (Selector_Name (P))) = E_Entry
2311 ("attribute % must apply to entry of current task", P);
2314 Error_Attr ("invalid entry name", N);
2318 for J in reverse 0 .. Scope_Stack.Last loop
2319 S := Scope_Stack.Table (J).Entity;
2321 if S = Scope (Ent) then
2322 if Nkind (P) = N_Expanded_Name then
2323 Tsk := Entity (Prefix (P));
2325 -- The prefix denotes either the task type, or else a
2326 -- single task whose task type is being analyzed.
2331 or else (not Is_Type (Tsk)
2332 and then Etype (Tsk) = S
2333 and then not (Comes_From_Source (S)))
2338 ("Attribute % must apply to entry of current task", N);
2344 elsif Ekind (Scope (Ent)) in Task_Kind
2345 and then Ekind (S) /= E_Loop
2346 and then Ekind (S) /= E_Block
2347 and then Ekind (S) /= E_Entry
2348 and then Ekind (S) /= E_Entry_Family
2350 Error_Attr ("Attribute % cannot appear in inner unit", N);
2352 elsif Ekind (Scope (Ent)) = E_Protected_Type
2353 and then not Has_Completion (Scope (Ent))
2355 Error_Attr ("attribute % can only be used inside body", N);
2359 if Is_Overloaded (P) then
2361 Index : Interp_Index;
2365 Get_First_Interp (P, Index, It);
2367 while Present (It.Nam) loop
2368 if It.Nam = Ent then
2372 Error_Attr ("ambiguous entry name", N);
2375 Get_Next_Interp (Index, It);
2380 Set_Etype (N, Universal_Integer);
2383 -----------------------
2384 -- Default_Bit_Order --
2385 -----------------------
2387 when Attribute_Default_Bit_Order => Default_Bit_Order :
2389 Check_Standard_Prefix;
2392 if Bytes_Big_Endian then
2394 Make_Integer_Literal (Loc, False_Value));
2397 Make_Integer_Literal (Loc, True_Value));
2400 Set_Etype (N, Universal_Integer);
2401 Set_Is_Static_Expression (N);
2402 end Default_Bit_Order;
2408 when Attribute_Definite =>
2409 Legal_Formal_Attribute;
2415 when Attribute_Delta =>
2416 Check_Fixed_Point_Type_0;
2417 Set_Etype (N, Universal_Real);
2423 when Attribute_Denorm =>
2424 Check_Floating_Point_Type_0;
2425 Set_Etype (N, Standard_Boolean);
2431 when Attribute_Digits =>
2435 if not Is_Floating_Point_Type (P_Type)
2436 and then not Is_Decimal_Fixed_Point_Type (P_Type)
2439 ("prefix of % attribute must be float or decimal type", P);
2442 Set_Etype (N, Universal_Integer);
2448 -- Also handles processing for Elab_Spec
2450 when Attribute_Elab_Body | Attribute_Elab_Spec =>
2452 Check_Unit_Name (P);
2453 Set_Etype (N, Standard_Void_Type);
2455 -- We have to manually call the expander in this case to get
2456 -- the necessary expansion (normally attributes that return
2457 -- entities are not expanded).
2465 -- Shares processing with Elab_Body
2471 when Attribute_Elaborated =>
2474 Set_Etype (N, Standard_Boolean);
2480 when Attribute_Emax =>
2481 Check_Floating_Point_Type_0;
2482 Set_Etype (N, Universal_Integer);
2488 when Attribute_Enum_Rep => Enum_Rep : declare
2490 if Present (E1) then
2492 Check_Discrete_Type;
2493 Resolve (E1, P_Base_Type);
2496 if not Is_Entity_Name (P)
2497 or else (not Is_Object (Entity (P))
2499 Ekind (Entity (P)) /= E_Enumeration_Literal)
2502 ("prefix of %attribute must be " &
2503 "discrete type/object or enum literal", P);
2507 Set_Etype (N, Universal_Integer);
2514 when Attribute_Epsilon =>
2515 Check_Floating_Point_Type_0;
2516 Set_Etype (N, Universal_Real);
2522 when Attribute_Exponent =>
2523 Check_Floating_Point_Type_1;
2524 Set_Etype (N, Universal_Integer);
2525 Resolve (E1, P_Base_Type);
2531 when Attribute_External_Tag =>
2535 Set_Etype (N, Standard_String);
2537 if not Is_Tagged_Type (P_Type) then
2538 Error_Attr ("prefix of % attribute must be tagged", P);
2545 when Attribute_First =>
2546 Check_Array_Or_Scalar_Type;
2552 when Attribute_First_Bit =>
2554 Set_Etype (N, Universal_Integer);
2560 when Attribute_Fixed_Value =>
2562 Check_Fixed_Point_Type;
2563 Resolve (E1, Any_Integer);
2564 Set_Etype (N, P_Base_Type);
2570 when Attribute_Floor =>
2571 Check_Floating_Point_Type_1;
2572 Set_Etype (N, P_Base_Type);
2573 Resolve (E1, P_Base_Type);
2579 when Attribute_Fore =>
2580 Check_Fixed_Point_Type_0;
2581 Set_Etype (N, Universal_Integer);
2587 when Attribute_Fraction =>
2588 Check_Floating_Point_Type_1;
2589 Set_Etype (N, P_Base_Type);
2590 Resolve (E1, P_Base_Type);
2592 -----------------------
2593 -- Has_Discriminants --
2594 -----------------------
2596 when Attribute_Has_Discriminants =>
2597 Legal_Formal_Attribute;
2603 when Attribute_Identity =>
2607 if Etype (P) = Standard_Exception_Type then
2608 Set_Etype (N, RTE (RE_Exception_Id));
2610 elsif Is_Task_Type (Etype (P))
2611 or else (Is_Access_Type (Etype (P))
2612 and then Is_Task_Type (Designated_Type (Etype (P))))
2615 Set_Etype (N, RTE (RO_AT_Task_ID));
2618 Error_Attr ("prefix of % attribute must be a task or an "
2626 when Attribute_Image => Image :
2628 Set_Etype (N, Standard_String);
2631 if Is_Real_Type (P_Type) then
2632 if Ada_83 and then Comes_From_Source (N) then
2633 Error_Msg_Name_1 := Aname;
2635 ("(Ada 83) % attribute not allowed for real types", N);
2639 if Is_Enumeration_Type (P_Type) then
2640 Check_Restriction (No_Enumeration_Maps, N);
2644 Resolve (E1, P_Base_Type);
2646 Validate_Non_Static_Attribute_Function_Call;
2653 when Attribute_Img => Img :
2655 Set_Etype (N, Standard_String);
2657 if not Is_Scalar_Type (P_Type)
2658 or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
2661 ("prefix of % attribute must be scalar object name", N);
2671 when Attribute_Input =>
2673 Check_Stream_Attribute (TSS_Stream_Input);
2674 Set_Etype (N, P_Base_Type);
2680 when Attribute_Integer_Value =>
2683 Resolve (E1, Any_Fixed);
2684 Set_Etype (N, P_Base_Type);
2690 when Attribute_Large =>
2693 Set_Etype (N, Universal_Real);
2699 when Attribute_Last =>
2700 Check_Array_Or_Scalar_Type;
2706 when Attribute_Last_Bit =>
2708 Set_Etype (N, Universal_Integer);
2714 when Attribute_Leading_Part =>
2715 Check_Floating_Point_Type_2;
2716 Set_Etype (N, P_Base_Type);
2717 Resolve (E1, P_Base_Type);
2718 Resolve (E2, Any_Integer);
2724 when Attribute_Length =>
2726 Set_Etype (N, Universal_Integer);
2732 when Attribute_Machine =>
2733 Check_Floating_Point_Type_1;
2734 Set_Etype (N, P_Base_Type);
2735 Resolve (E1, P_Base_Type);
2741 when Attribute_Machine_Emax =>
2742 Check_Floating_Point_Type_0;
2743 Set_Etype (N, Universal_Integer);
2749 when Attribute_Machine_Emin =>
2750 Check_Floating_Point_Type_0;
2751 Set_Etype (N, Universal_Integer);
2753 ----------------------
2754 -- Machine_Mantissa --
2755 ----------------------
2757 when Attribute_Machine_Mantissa =>
2758 Check_Floating_Point_Type_0;
2759 Set_Etype (N, Universal_Integer);
2761 -----------------------
2762 -- Machine_Overflows --
2763 -----------------------
2765 when Attribute_Machine_Overflows =>
2768 Set_Etype (N, Standard_Boolean);
2774 when Attribute_Machine_Radix =>
2777 Set_Etype (N, Universal_Integer);
2779 --------------------
2780 -- Machine_Rounds --
2781 --------------------
2783 when Attribute_Machine_Rounds =>
2786 Set_Etype (N, Standard_Boolean);
2792 when Attribute_Machine_Size =>
2795 Check_Not_Incomplete_Type;
2796 Set_Etype (N, Universal_Integer);
2802 when Attribute_Mantissa =>
2805 Set_Etype (N, Universal_Integer);
2811 when Attribute_Max =>
2814 Resolve (E1, P_Base_Type);
2815 Resolve (E2, P_Base_Type);
2816 Set_Etype (N, P_Base_Type);
2818 ----------------------------------
2819 -- Max_Size_In_Storage_Elements --
2820 ----------------------------------
2822 when Attribute_Max_Size_In_Storage_Elements =>
2825 Check_Not_Incomplete_Type;
2826 Set_Etype (N, Universal_Integer);
2828 -----------------------
2829 -- Maximum_Alignment --
2830 -----------------------
2832 when Attribute_Maximum_Alignment =>
2833 Standard_Attribute (Ttypes.Maximum_Alignment);
2835 --------------------
2836 -- Mechanism_Code --
2837 --------------------
2839 when Attribute_Mechanism_Code =>
2840 if not Is_Entity_Name (P)
2841 or else not Is_Subprogram (Entity (P))
2843 Error_Attr ("prefix of % attribute must be subprogram", P);
2846 Check_Either_E0_Or_E1;
2848 if Present (E1) then
2849 Resolve (E1, Any_Integer);
2850 Set_Etype (E1, Standard_Integer);
2852 if not Is_Static_Expression (E1) then
2853 Flag_Non_Static_Expr
2854 ("expression for parameter number must be static!", E1);
2857 elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
2858 or else UI_To_Int (Intval (E1)) < 0
2860 Error_Attr ("invalid parameter number for %attribute", E1);
2864 Set_Etype (N, Universal_Integer);
2870 when Attribute_Min =>
2873 Resolve (E1, P_Base_Type);
2874 Resolve (E2, P_Base_Type);
2875 Set_Etype (N, P_Base_Type);
2881 when Attribute_Model =>
2882 Check_Floating_Point_Type_1;
2883 Set_Etype (N, P_Base_Type);
2884 Resolve (E1, P_Base_Type);
2890 when Attribute_Model_Emin =>
2891 Check_Floating_Point_Type_0;
2892 Set_Etype (N, Universal_Integer);
2898 when Attribute_Model_Epsilon =>
2899 Check_Floating_Point_Type_0;
2900 Set_Etype (N, Universal_Real);
2902 --------------------
2903 -- Model_Mantissa --
2904 --------------------
2906 when Attribute_Model_Mantissa =>
2907 Check_Floating_Point_Type_0;
2908 Set_Etype (N, Universal_Integer);
2914 when Attribute_Model_Small =>
2915 Check_Floating_Point_Type_0;
2916 Set_Etype (N, Universal_Real);
2922 when Attribute_Modulus =>
2926 if not Is_Modular_Integer_Type (P_Type) then
2927 Error_Attr ("prefix of % attribute must be modular type", P);
2930 Set_Etype (N, Universal_Integer);
2932 --------------------
2933 -- Null_Parameter --
2934 --------------------
2936 when Attribute_Null_Parameter => Null_Parameter : declare
2937 Parnt : constant Node_Id := Parent (N);
2938 GParnt : constant Node_Id := Parent (Parnt);
2940 procedure Bad_Null_Parameter (Msg : String);
2941 -- Used if bad Null parameter attribute node is found. Issues
2942 -- given error message, and also sets the type to Any_Type to
2943 -- avoid blowups later on from dealing with a junk node.
2945 procedure Must_Be_Imported (Proc_Ent : Entity_Id);
2946 -- Called to check that Proc_Ent is imported subprogram
2948 ------------------------
2949 -- Bad_Null_Parameter --
2950 ------------------------
2952 procedure Bad_Null_Parameter (Msg : String) is
2954 Error_Msg_N (Msg, N);
2955 Set_Etype (N, Any_Type);
2956 end Bad_Null_Parameter;
2958 ----------------------
2959 -- Must_Be_Imported --
2960 ----------------------
2962 procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
2963 Pent : Entity_Id := Proc_Ent;
2966 while Present (Alias (Pent)) loop
2967 Pent := Alias (Pent);
2970 -- Ignore check if procedure not frozen yet (we will get
2971 -- another chance when the default parameter is reanalyzed)
2973 if not Is_Frozen (Pent) then
2976 elsif not Is_Imported (Pent) then
2978 ("Null_Parameter can only be used with imported subprogram");
2983 end Must_Be_Imported;
2985 -- Start of processing for Null_Parameter
2990 Set_Etype (N, P_Type);
2992 -- Case of attribute used as default expression
2994 if Nkind (Parnt) = N_Parameter_Specification then
2995 Must_Be_Imported (Defining_Entity (GParnt));
2997 -- Case of attribute used as actual for subprogram (positional)
2999 elsif (Nkind (Parnt) = N_Procedure_Call_Statement
3001 Nkind (Parnt) = N_Function_Call)
3002 and then Is_Entity_Name (Name (Parnt))
3004 Must_Be_Imported (Entity (Name (Parnt)));
3006 -- Case of attribute used as actual for subprogram (named)
3008 elsif Nkind (Parnt) = N_Parameter_Association
3009 and then (Nkind (GParnt) = N_Procedure_Call_Statement
3011 Nkind (GParnt) = N_Function_Call)
3012 and then Is_Entity_Name (Name (GParnt))
3014 Must_Be_Imported (Entity (Name (GParnt)));
3016 -- Not an allowed case
3020 ("Null_Parameter must be actual or default parameter");
3029 when Attribute_Object_Size =>
3032 Check_Not_Incomplete_Type;
3033 Set_Etype (N, Universal_Integer);
3039 when Attribute_Output =>
3041 Check_Stream_Attribute (TSS_Stream_Output);
3042 Set_Etype (N, Standard_Void_Type);
3043 Resolve (N, Standard_Void_Type);
3049 when Attribute_Partition_ID =>
3052 if P_Type /= Any_Type then
3053 if not Is_Library_Level_Entity (Entity (P)) then
3055 ("prefix of % attribute must be library-level entity", P);
3057 -- The defining entity of prefix should not be declared inside
3058 -- a Pure unit. RM E.1(8).
3059 -- The Is_Pure flag has been set during declaration.
3061 elsif Is_Entity_Name (P)
3062 and then Is_Pure (Entity (P))
3065 ("prefix of % attribute must not be declared pure", P);
3069 Set_Etype (N, Universal_Integer);
3071 -------------------------
3072 -- Passed_By_Reference --
3073 -------------------------
3075 when Attribute_Passed_By_Reference =>
3078 Set_Etype (N, Standard_Boolean);
3084 when Attribute_Pool_Address =>
3086 Set_Etype (N, RTE (RE_Address));
3092 when Attribute_Pos =>
3093 Check_Discrete_Type;
3095 Resolve (E1, P_Base_Type);
3096 Set_Etype (N, Universal_Integer);
3102 when Attribute_Position =>
3104 Set_Etype (N, Universal_Integer);
3110 when Attribute_Pred =>
3113 Resolve (E1, P_Base_Type);
3114 Set_Etype (N, P_Base_Type);
3116 -- Nothing to do for real type case
3118 if Is_Real_Type (P_Type) then
3121 -- If not modular type, test for overflow check required
3124 if not Is_Modular_Integer_Type (P_Type)
3125 and then not Range_Checks_Suppressed (P_Base_Type)
3127 Enable_Range_Check (E1);
3135 when Attribute_Range =>
3136 Check_Array_Or_Scalar_Type;
3139 and then Is_Scalar_Type (P_Type)
3140 and then Comes_From_Source (N)
3143 ("(Ada 83) % attribute not allowed for scalar type", P);
3150 when Attribute_Range_Length =>
3151 Check_Discrete_Type;
3152 Set_Etype (N, Universal_Integer);
3158 when Attribute_Read =>
3160 Check_Stream_Attribute (TSS_Stream_Read);
3161 Set_Etype (N, Standard_Void_Type);
3162 Resolve (N, Standard_Void_Type);
3163 Note_Possible_Modification (E2);
3169 when Attribute_Remainder =>
3170 Check_Floating_Point_Type_2;
3171 Set_Etype (N, P_Base_Type);
3172 Resolve (E1, P_Base_Type);
3173 Resolve (E2, P_Base_Type);
3179 when Attribute_Round =>
3181 Check_Decimal_Fixed_Point_Type;
3182 Set_Etype (N, P_Base_Type);
3184 -- Because the context is universal_real (3.5.10(12)) it is a legal
3185 -- context for a universal fixed expression. This is the only
3186 -- attribute whose functional description involves U_R.
3188 if Etype (E1) = Universal_Fixed then
3190 Conv : constant Node_Id := Make_Type_Conversion (Loc,
3191 Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
3192 Expression => Relocate_Node (E1));
3200 Resolve (E1, Any_Real);
3206 when Attribute_Rounding =>
3207 Check_Floating_Point_Type_1;
3208 Set_Etype (N, P_Base_Type);
3209 Resolve (E1, P_Base_Type);
3215 when Attribute_Safe_Emax =>
3216 Check_Floating_Point_Type_0;
3217 Set_Etype (N, Universal_Integer);
3223 when Attribute_Safe_First =>
3224 Check_Floating_Point_Type_0;
3225 Set_Etype (N, Universal_Real);
3231 when Attribute_Safe_Large =>
3234 Set_Etype (N, Universal_Real);
3240 when Attribute_Safe_Last =>
3241 Check_Floating_Point_Type_0;
3242 Set_Etype (N, Universal_Real);
3248 when Attribute_Safe_Small =>
3251 Set_Etype (N, Universal_Real);
3257 when Attribute_Scale =>
3259 Check_Decimal_Fixed_Point_Type;
3260 Set_Etype (N, Universal_Integer);
3266 when Attribute_Scaling =>
3267 Check_Floating_Point_Type_2;
3268 Set_Etype (N, P_Base_Type);
3269 Resolve (E1, P_Base_Type);
3275 when Attribute_Signed_Zeros =>
3276 Check_Floating_Point_Type_0;
3277 Set_Etype (N, Standard_Boolean);
3283 when Attribute_Size | Attribute_VADS_Size =>
3286 if Is_Object_Reference (P)
3287 or else (Is_Entity_Name (P)
3288 and then Ekind (Entity (P)) = E_Function)
3290 Check_Object_Reference (P);
3292 elsif Is_Entity_Name (P)
3293 and then Is_Type (Entity (P))
3297 elsif Nkind (P) = N_Type_Conversion
3298 and then not Comes_From_Source (P)
3303 Error_Attr ("invalid prefix for % attribute", P);
3306 Check_Not_Incomplete_Type;
3307 Set_Etype (N, Universal_Integer);
3313 when Attribute_Small =>
3316 Set_Etype (N, Universal_Real);
3322 when Attribute_Storage_Pool =>
3323 if Is_Access_Type (P_Type) then
3326 -- Set appropriate entity
3328 if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
3329 Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
3331 Set_Entity (N, RTE (RE_Global_Pool_Object));
3334 Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
3336 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
3337 -- Storage_Pool since this attribute is not defined for such
3338 -- types (RM E.2.3(22)).
3340 Validate_Remote_Access_To_Class_Wide_Type (N);
3343 Error_Attr ("prefix of % attribute must be access type", P);
3350 when Attribute_Storage_Size =>
3352 if Is_Task_Type (P_Type) then
3354 Set_Etype (N, Universal_Integer);
3356 elsif Is_Access_Type (P_Type) then
3357 if Is_Entity_Name (P)
3358 and then Is_Type (Entity (P))
3362 Set_Etype (N, Universal_Integer);
3364 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
3365 -- Storage_Size since this attribute is not defined for
3366 -- such types (RM E.2.3(22)).
3368 Validate_Remote_Access_To_Class_Wide_Type (N);
3370 -- The prefix is allowed to be an implicit dereference
3371 -- of an access value designating a task.
3376 Set_Etype (N, Universal_Integer);
3381 ("prefix of % attribute must be access or task type", P);
3388 when Attribute_Storage_Unit =>
3389 Standard_Attribute (Ttypes.System_Storage_Unit);
3395 when Attribute_Succ =>
3398 Resolve (E1, P_Base_Type);
3399 Set_Etype (N, P_Base_Type);
3401 -- Nothing to do for real type case
3403 if Is_Real_Type (P_Type) then
3406 -- If not modular type, test for overflow check required.
3409 if not Is_Modular_Integer_Type (P_Type)
3410 and then not Range_Checks_Suppressed (P_Base_Type)
3412 Enable_Range_Check (E1);
3420 when Attribute_Tag =>
3424 if not Is_Tagged_Type (P_Type) then
3425 Error_Attr ("prefix of % attribute must be tagged", P);
3427 -- Next test does not apply to generated code
3428 -- why not, and what does the illegal reference mean???
3430 elsif Is_Object_Reference (P)
3431 and then not Is_Class_Wide_Type (P_Type)
3432 and then Comes_From_Source (N)
3435 ("% attribute can only be applied to objects of class-wide type",
3439 Set_Etype (N, RTE (RE_Tag));
3445 when Attribute_Target_Name => Target_Name : declare
3446 TN : constant String := Sdefault.Target_Name.all;
3447 TL : Integer := TN'Last;
3450 Check_Standard_Prefix;
3454 if TN (TL) = '/' or else TN (TL) = '\' then
3458 Store_String_Chars (TN (TN'First .. TL));
3461 Make_String_Literal (Loc,
3462 Strval => End_String));
3463 Analyze_And_Resolve (N, Standard_String);
3470 when Attribute_Terminated =>
3472 Set_Etype (N, Standard_Boolean);
3479 when Attribute_To_Address =>
3483 if Nkind (P) /= N_Identifier
3484 or else Chars (P) /= Name_System
3486 Error_Attr ("prefix of %attribute must be System", P);
3489 Generate_Reference (RTE (RE_Address), P);
3490 Analyze_And_Resolve (E1, Any_Integer);
3491 Set_Etype (N, RTE (RE_Address));
3497 when Attribute_Truncation =>
3498 Check_Floating_Point_Type_1;
3499 Resolve (E1, P_Base_Type);
3500 Set_Etype (N, P_Base_Type);
3506 when Attribute_Type_Class =>
3509 Check_Not_Incomplete_Type;
3510 Set_Etype (N, RTE (RE_Type_Class));
3516 when Attribute_UET_Address =>
3518 Check_Unit_Name (P);
3519 Set_Etype (N, RTE (RE_Address));
3521 -----------------------
3522 -- Unbiased_Rounding --
3523 -----------------------
3525 when Attribute_Unbiased_Rounding =>
3526 Check_Floating_Point_Type_1;
3527 Set_Etype (N, P_Base_Type);
3528 Resolve (E1, P_Base_Type);
3530 ----------------------
3531 -- Unchecked_Access --
3532 ----------------------
3534 when Attribute_Unchecked_Access =>
3535 if Comes_From_Source (N) then
3536 Check_Restriction (No_Unchecked_Access, N);
3539 Analyze_Access_Attribute;
3541 -------------------------
3542 -- Unconstrained_Array --
3543 -------------------------
3545 when Attribute_Unconstrained_Array =>
3548 Check_Not_Incomplete_Type;
3549 Set_Etype (N, Standard_Boolean);
3551 ------------------------------
3552 -- Universal_Literal_String --
3553 ------------------------------
3555 -- This is a GNAT specific attribute whose prefix must be a named
3556 -- number where the expression is either a single numeric literal,
3557 -- or a numeric literal immediately preceded by a minus sign. The
3558 -- result is equivalent to a string literal containing the text of
3559 -- the literal as it appeared in the source program with a possible
3560 -- leading minus sign.
3562 when Attribute_Universal_Literal_String => Universal_Literal_String :
3566 if not Is_Entity_Name (P)
3567 or else Ekind (Entity (P)) not in Named_Kind
3569 Error_Attr ("prefix for % attribute must be named number", P);
3576 Src : Source_Buffer_Ptr;
3579 Expr := Original_Node (Expression (Parent (Entity (P))));
3581 if Nkind (Expr) = N_Op_Minus then
3583 Expr := Original_Node (Right_Opnd (Expr));
3588 if Nkind (Expr) /= N_Integer_Literal
3589 and then Nkind (Expr) /= N_Real_Literal
3592 ("named number for % attribute must be simple literal", N);
3595 -- Build string literal corresponding to source literal text
3600 Store_String_Char (Get_Char_Code ('-'));
3604 Src := Source_Text (Get_Source_File_Index (S));
3606 while Src (S) /= ';' and then Src (S) /= ' ' loop
3607 Store_String_Char (Get_Char_Code (Src (S)));
3611 -- Now we rewrite the attribute with the string literal
3614 Make_String_Literal (Loc, End_String));
3618 end Universal_Literal_String;
3620 -------------------------
3621 -- Unrestricted_Access --
3622 -------------------------
3624 -- This is a GNAT specific attribute which is like Access except that
3625 -- all scope checks and checks for aliased views are omitted.
3627 when Attribute_Unrestricted_Access =>
3628 if Comes_From_Source (N) then
3629 Check_Restriction (No_Unchecked_Access, N);
3632 if Is_Entity_Name (P) then
3633 Set_Address_Taken (Entity (P));
3636 Analyze_Access_Attribute;
3642 when Attribute_Val => Val : declare
3645 Check_Discrete_Type;
3646 Resolve (E1, Any_Integer);
3647 Set_Etype (N, P_Base_Type);
3649 -- Note, we need a range check in general, but we wait for the
3650 -- Resolve call to do this, since we want to let Eval_Attribute
3651 -- have a chance to find an static illegality first!
3658 when Attribute_Valid =>
3661 -- Ignore check for object if we have a 'Valid reference generated
3662 -- by the expanded code, since in some cases valid checks can occur
3663 -- on items that are names, but are not objects (e.g. attributes).
3665 if Comes_From_Source (N) then
3666 Check_Object_Reference (P);
3669 if not Is_Scalar_Type (P_Type) then
3670 Error_Attr ("object for % attribute must be of scalar type", P);
3673 Set_Etype (N, Standard_Boolean);
3679 when Attribute_Value => Value :
3684 if Is_Enumeration_Type (P_Type) then
3685 Check_Restriction (No_Enumeration_Maps, N);
3688 -- Set Etype before resolving expression because expansion of
3689 -- expression may require enclosing type. Note that the type
3690 -- returned by 'Value is the base type of the prefix type.
3692 Set_Etype (N, P_Base_Type);
3693 Validate_Non_Static_Attribute_Function_Call;
3700 when Attribute_Value_Size =>
3703 Check_Not_Incomplete_Type;
3704 Set_Etype (N, Universal_Integer);
3710 when Attribute_Version =>
3713 Set_Etype (N, RTE (RE_Version_String));
3719 when Attribute_Wchar_T_Size =>
3720 Standard_Attribute (Interfaces_Wchar_T_Size);
3726 when Attribute_Wide_Image => Wide_Image :
3729 Set_Etype (N, Standard_Wide_String);
3731 Resolve (E1, P_Base_Type);
3732 Validate_Non_Static_Attribute_Function_Call;
3739 when Attribute_Wide_Value => Wide_Value :
3744 -- Set Etype before resolving expression because expansion
3745 -- of expression may require enclosing type.
3747 Set_Etype (N, P_Type);
3748 Validate_Non_Static_Attribute_Function_Call;
3755 when Attribute_Wide_Width =>
3758 Set_Etype (N, Universal_Integer);
3764 when Attribute_Width =>
3767 Set_Etype (N, Universal_Integer);
3773 when Attribute_Word_Size =>
3774 Standard_Attribute (System_Word_Size);
3780 when Attribute_Write =>
3782 Check_Stream_Attribute (TSS_Stream_Write);
3783 Set_Etype (N, Standard_Void_Type);
3784 Resolve (N, Standard_Void_Type);
3788 -- All errors raise Bad_Attribute, so that we get out before any further
3789 -- damage occurs when an error is detected (for example, if we check for
3790 -- one attribute expression, and the check succeeds, we want to be able
3791 -- to proceed securely assuming that an expression is in fact present.
3794 when Bad_Attribute =>
3795 Set_Etype (N, Any_Type);
3798 end Analyze_Attribute;
3800 --------------------
3801 -- Eval_Attribute --
3802 --------------------
3804 procedure Eval_Attribute (N : Node_Id) is
3805 Loc : constant Source_Ptr := Sloc (N);
3806 Aname : constant Name_Id := Attribute_Name (N);
3807 Id : constant Attribute_Id := Get_Attribute_Id (Aname);
3808 P : constant Node_Id := Prefix (N);
3810 C_Type : constant Entity_Id := Etype (N);
3811 -- The type imposed by the context.
3814 -- First expression, or Empty if none
3817 -- Second expression, or Empty if none
3819 P_Entity : Entity_Id;
3820 -- Entity denoted by prefix
3823 -- The type of the prefix
3825 P_Base_Type : Entity_Id;
3826 -- The base type of the prefix type
3828 P_Root_Type : Entity_Id;
3829 -- The root type of the prefix type
3832 -- True if the result is Static. This is set by the general processing
3833 -- to true if the prefix is static, and all expressions are static. It
3834 -- can be reset as processing continues for particular attributes
3836 Lo_Bound, Hi_Bound : Node_Id;
3837 -- Expressions for low and high bounds of type or array index referenced
3838 -- by First, Last, or Length attribute for array, set by Set_Bounds.
3841 -- Constraint error node used if we have an attribute reference has
3842 -- an argument that raises a constraint error. In this case we replace
3843 -- the attribute with a raise constraint_error node. This is important
3844 -- processing, since otherwise gigi might see an attribute which it is
3845 -- unprepared to deal with.
3847 function Aft_Value return Nat;
3848 -- Computes Aft value for current attribute prefix (used by Aft itself
3849 -- and also by Width for computing the Width of a fixed point type).
3851 procedure Check_Expressions;
3852 -- In case where the attribute is not foldable, the expressions, if
3853 -- any, of the attribute, are in a non-static context. This procedure
3854 -- performs the required additional checks.
3856 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
3857 -- Determines if the given type has compile time known bounds. Note
3858 -- that we enter the case statement even in cases where the prefix
3859 -- type does NOT have known bounds, so it is important to guard any
3860 -- attempt to evaluate both bounds with a call to this function.
3862 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
3863 -- This procedure is called when the attribute N has a non-static
3864 -- but compile time known value given by Val. It includes the
3865 -- necessary checks for out of range values.
3867 procedure Float_Attribute_Universal_Integer
3876 -- This procedure evaluates a float attribute with no arguments that
3877 -- returns a universal integer result. The parameters give the values
3878 -- for the possible floating-point root types. See ttypef for details.
3879 -- The prefix type is a float type (and is thus not a generic type).
3881 procedure Float_Attribute_Universal_Real
3882 (IEEES_Val : String;
3889 AAMPL_Val : String);
3890 -- This procedure evaluates a float attribute with no arguments that
3891 -- returns a universal real result. The parameters give the values
3892 -- required for the possible floating-point root types in string
3893 -- format as real literals with a possible leading minus sign.
3894 -- The prefix type is a float type (and is thus not a generic type).
3896 function Fore_Value return Nat;
3897 -- Computes the Fore value for the current attribute prefix, which is
3898 -- known to be a static fixed-point type. Used by Fore and Width.
3900 function Mantissa return Uint;
3901 -- Returns the Mantissa value for the prefix type
3903 procedure Set_Bounds;
3904 -- Used for First, Last and Length attributes applied to an array or
3905 -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
3906 -- and high bound expressions for the index referenced by the attribute
3907 -- designator (i.e. the first index if no expression is present, and
3908 -- the N'th index if the value N is present as an expression). Also
3909 -- used for First and Last of scalar types. Static is reset to False
3910 -- if the type or index type is not statically constrained.
3916 function Aft_Value return Nat is
3922 Delta_Val := Delta_Value (P_Type);
3924 while Delta_Val < Ureal_Tenth loop
3925 Delta_Val := Delta_Val * Ureal_10;
3926 Result := Result + 1;
3932 -----------------------
3933 -- Check_Expressions --
3934 -----------------------
3936 procedure Check_Expressions is
3940 while Present (E) loop
3941 Check_Non_Static_Context (E);
3944 end Check_Expressions;
3946 ----------------------------------
3947 -- Compile_Time_Known_Attribute --
3948 ----------------------------------
3950 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is
3951 T : constant Entity_Id := Etype (N);
3954 Fold_Uint (N, Val, False);
3956 -- Check that result is in bounds of the type if it is static
3958 if Is_In_Range (N, T) then
3961 elsif Is_Out_Of_Range (N, T) then
3962 Apply_Compile_Time_Constraint_Error
3963 (N, "value not in range of}?", CE_Range_Check_Failed);
3965 elsif not Range_Checks_Suppressed (T) then
3966 Enable_Range_Check (N);
3969 Set_Do_Range_Check (N, False);
3971 end Compile_Time_Known_Attribute;
3973 -------------------------------
3974 -- Compile_Time_Known_Bounds --
3975 -------------------------------
3977 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
3980 Compile_Time_Known_Value (Type_Low_Bound (Typ))
3982 Compile_Time_Known_Value (Type_High_Bound (Typ));
3983 end Compile_Time_Known_Bounds;
3985 ---------------------------------------
3986 -- Float_Attribute_Universal_Integer --
3987 ---------------------------------------
3989 procedure Float_Attribute_Universal_Integer
4000 Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
4003 if Vax_Float (P_Base_Type) then
4004 if Digs = VAXFF_Digits then
4006 elsif Digs = VAXDF_Digits then
4008 else pragma Assert (Digs = VAXGF_Digits);
4012 elsif Is_AAMP_Float (P_Base_Type) then
4013 if Digs = AAMPS_Digits then
4015 else pragma Assert (Digs = AAMPL_Digits);
4020 if Digs = IEEES_Digits then
4022 elsif Digs = IEEEL_Digits then
4024 else pragma Assert (Digs = IEEEX_Digits);
4029 Fold_Uint (N, UI_From_Int (Val), True);
4030 end Float_Attribute_Universal_Integer;
4032 ------------------------------------
4033 -- Float_Attribute_Universal_Real --
4034 ------------------------------------
4036 procedure Float_Attribute_Universal_Real
4037 (IEEES_Val : String;
4047 Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
4050 if Vax_Float (P_Base_Type) then
4051 if Digs = VAXFF_Digits then
4052 Val := Real_Convert (VAXFF_Val);
4053 elsif Digs = VAXDF_Digits then
4054 Val := Real_Convert (VAXDF_Val);
4055 else pragma Assert (Digs = VAXGF_Digits);
4056 Val := Real_Convert (VAXGF_Val);
4059 elsif Is_AAMP_Float (P_Base_Type) then
4060 if Digs = AAMPS_Digits then
4061 Val := Real_Convert (AAMPS_Val);
4062 else pragma Assert (Digs = AAMPL_Digits);
4063 Val := Real_Convert (AAMPL_Val);
4067 if Digs = IEEES_Digits then
4068 Val := Real_Convert (IEEES_Val);
4069 elsif Digs = IEEEL_Digits then
4070 Val := Real_Convert (IEEEL_Val);
4071 else pragma Assert (Digs = IEEEX_Digits);
4072 Val := Real_Convert (IEEEX_Val);
4076 Set_Sloc (Val, Loc);
4078 Set_Is_Static_Expression (N, Static);
4079 Analyze_And_Resolve (N, C_Type);
4080 end Float_Attribute_Universal_Real;
4086 -- Note that the Fore calculation is based on the actual values
4087 -- of the bounds, and does not take into account possible rounding.
4089 function Fore_Value return Nat is
4090 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
4091 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
4092 Small : constant Ureal := Small_Value (P_Type);
4093 Lo_Real : constant Ureal := Lo * Small;
4094 Hi_Real : constant Ureal := Hi * Small;
4099 -- Bounds are given in terms of small units, so first compute
4100 -- proper values as reals.
4102 T := UR_Max (abs Lo_Real, abs Hi_Real);
4105 -- Loop to compute proper value if more than one digit required
4107 while T >= Ureal_10 loop
4119 -- Table of mantissa values accessed by function Computed using
4122 -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
4124 -- where D is T'Digits (RM83 3.5.7)
4126 Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
4168 function Mantissa return Uint is
4171 UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
4178 procedure Set_Bounds is
4184 -- For a string literal subtype, we have to construct the bounds.
4185 -- Valid Ada code never applies attributes to string literals, but
4186 -- it is convenient to allow the expander to generate attribute
4187 -- references of this type (e.g. First and Last applied to a string
4190 -- Note that the whole point of the E_String_Literal_Subtype is to
4191 -- avoid this construction of bounds, but the cases in which we
4192 -- have to materialize them are rare enough that we don't worry!
4194 -- The low bound is simply the low bound of the base type. The
4195 -- high bound is computed from the length of the string and this
4198 if Ekind (P_Type) = E_String_Literal_Subtype then
4199 Ityp := Etype (First_Index (Base_Type (P_Type)));
4200 Lo_Bound := Type_Low_Bound (Ityp);
4203 Make_Integer_Literal (Sloc (P),
4205 Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
4207 Set_Parent (Hi_Bound, P);
4208 Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
4211 -- For non-array case, just get bounds of scalar type
4213 elsif Is_Scalar_Type (P_Type) then
4216 -- For a fixed-point type, we must freeze to get the attributes
4217 -- of the fixed-point type set now so we can reference them.
4219 if Is_Fixed_Point_Type (P_Type)
4220 and then not Is_Frozen (Base_Type (P_Type))
4221 and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
4222 and then Compile_Time_Known_Value (Type_High_Bound (P_Type))
4224 Freeze_Fixed_Point_Type (Base_Type (P_Type));
4227 -- For array case, get type of proper index
4233 Ndim := UI_To_Int (Expr_Value (E1));
4236 Indx := First_Index (P_Type);
4237 for J in 1 .. Ndim - 1 loop
4241 -- If no index type, get out (some other error occurred, and
4242 -- we don't have enough information to complete the job!)
4250 Ityp := Etype (Indx);
4253 -- A discrete range in an index constraint is allowed to be a
4254 -- subtype indication. This is syntactically a pain, but should
4255 -- not propagate to the entity for the corresponding index subtype.
4256 -- After checking that the subtype indication is legal, the range
4257 -- of the subtype indication should be transfered to the entity.
4258 -- The attributes for the bounds should remain the simple retrievals
4259 -- that they are now.
4261 Lo_Bound := Type_Low_Bound (Ityp);
4262 Hi_Bound := Type_High_Bound (Ityp);
4264 if not Is_Static_Subtype (Ityp) then
4269 -- Start of processing for Eval_Attribute
4272 -- Acquire first two expressions (at the moment, no attributes
4273 -- take more than two expressions in any case).
4275 if Present (Expressions (N)) then
4276 E1 := First (Expressions (N));
4283 -- Special processing for cases where the prefix is an object. For
4284 -- this purpose, a string literal counts as an object (attributes
4285 -- of string literals can only appear in generated code).
4287 if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
4289 -- For Component_Size, the prefix is an array object, and we apply
4290 -- the attribute to the type of the object. This is allowed for
4291 -- both unconstrained and constrained arrays, since the bounds
4292 -- have no influence on the value of this attribute.
4294 if Id = Attribute_Component_Size then
4295 P_Entity := Etype (P);
4297 -- For First and Last, the prefix is an array object, and we apply
4298 -- the attribute to the type of the array, but we need a constrained
4299 -- type for this, so we use the actual subtype if available.
4301 elsif Id = Attribute_First
4305 Id = Attribute_Length
4308 AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
4311 if Present (AS) and then Is_Constrained (AS) then
4314 -- If we have an unconstrained type, cannot fold
4322 -- For Size, give size of object if available, otherwise we
4323 -- cannot fold Size.
4325 elsif Id = Attribute_Size then
4326 if Is_Entity_Name (P)
4327 and then Known_Esize (Entity (P))
4329 Compile_Time_Known_Attribute (N, Esize (Entity (P)));
4337 -- For Alignment, give size of object if available, otherwise we
4338 -- cannot fold Alignment.
4340 elsif Id = Attribute_Alignment then
4341 if Is_Entity_Name (P)
4342 and then Known_Alignment (Entity (P))
4344 Fold_Uint (N, Alignment (Entity (P)), False);
4352 -- No other attributes for objects are folded
4359 -- Cases where P is not an object. Cannot do anything if P is
4360 -- not the name of an entity.
4362 elsif not Is_Entity_Name (P) then
4366 -- Otherwise get prefix entity
4369 P_Entity := Entity (P);
4372 -- At this stage P_Entity is the entity to which the attribute
4373 -- is to be applied. This is usually simply the entity of the
4374 -- prefix, except in some cases of attributes for objects, where
4375 -- as described above, we apply the attribute to the object type.
4377 -- First foldable possibility is a scalar or array type (RM 4.9(7))
4378 -- that is not generic (generic types are eliminated by RM 4.9(25)).
4379 -- Note we allow non-static non-generic types at this stage as further
4382 if Is_Type (P_Entity)
4383 and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
4384 and then (not Is_Generic_Type (P_Entity))
4388 -- Second foldable possibility is an array object (RM 4.9(8))
4390 elsif (Ekind (P_Entity) = E_Variable
4392 Ekind (P_Entity) = E_Constant)
4393 and then Is_Array_Type (Etype (P_Entity))
4394 and then (not Is_Generic_Type (Etype (P_Entity)))
4396 P_Type := Etype (P_Entity);
4398 -- If the entity is an array constant with an unconstrained
4399 -- nominal subtype then get the type from the initial value.
4400 -- If the value has been expanded into assignments, the expression
4401 -- is not present and the attribute reference remains dynamic.
4402 -- We could do better here and retrieve the type ???
4404 if Ekind (P_Entity) = E_Constant
4405 and then not Is_Constrained (P_Type)
4407 if No (Constant_Value (P_Entity)) then
4410 P_Type := Etype (Constant_Value (P_Entity));
4414 -- Definite must be folded if the prefix is not a generic type,
4415 -- that is to say if we are within an instantiation. Same processing
4416 -- applies to the GNAT attributes Has_Discriminants, Type_Class,
4417 -- and Unconstrained_Array.
4419 elsif (Id = Attribute_Definite
4421 Id = Attribute_Has_Discriminants
4423 Id = Attribute_Type_Class
4425 Id = Attribute_Unconstrained_Array)
4426 and then not Is_Generic_Type (P_Entity)
4430 -- We can fold 'Size applied to a type if the size is known
4431 -- (as happens for a size from an attribute definition clause).
4432 -- At this stage, this can happen only for types (e.g. record
4433 -- types) for which the size is always non-static. We exclude
4434 -- generic types from consideration (since they have bogus
4435 -- sizes set within templates).
4437 elsif Id = Attribute_Size
4438 and then Is_Type (P_Entity)
4439 and then (not Is_Generic_Type (P_Entity))
4440 and then Known_Static_RM_Size (P_Entity)
4442 Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
4445 -- We can fold 'Alignment applied to a type if the alignment is known
4446 -- (as happens for an alignment from an attribute definition clause).
4447 -- At this stage, this can happen only for types (e.g. record
4448 -- types) for which the size is always non-static. We exclude
4449 -- generic types from consideration (since they have bogus
4450 -- sizes set within templates).
4452 elsif Id = Attribute_Alignment
4453 and then Is_Type (P_Entity)
4454 and then (not Is_Generic_Type (P_Entity))
4455 and then Known_Alignment (P_Entity)
4457 Compile_Time_Known_Attribute (N, Alignment (P_Entity));
4460 -- If this is an access attribute that is known to fail accessibility
4461 -- check, rewrite accordingly.
4463 elsif Attribute_Name (N) = Name_Access
4464 and then Raises_Constraint_Error (N)
4467 Make_Raise_Program_Error (Loc,
4468 Reason => PE_Accessibility_Check_Failed));
4469 Set_Etype (N, C_Type);
4472 -- No other cases are foldable (they certainly aren't static, and at
4473 -- the moment we don't try to fold any cases other than these three).
4480 -- If either attribute or the prefix is Any_Type, then propagate
4481 -- Any_Type to the result and don't do anything else at all.
4483 if P_Type = Any_Type
4484 or else (Present (E1) and then Etype (E1) = Any_Type)
4485 or else (Present (E2) and then Etype (E2) = Any_Type)
4487 Set_Etype (N, Any_Type);
4491 -- Scalar subtype case. We have not yet enforced the static requirement
4492 -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases
4493 -- of non-static attribute references (e.g. S'Digits for a non-static
4494 -- floating-point type, which we can compute at compile time).
4496 -- Note: this folding of non-static attributes is not simply a case of
4497 -- optimization. For many of the attributes affected, Gigi cannot handle
4498 -- the attribute and depends on the front end having folded them away.
4500 -- Note: although we don't require staticness at this stage, we do set
4501 -- the Static variable to record the staticness, for easy reference by
4502 -- those attributes where it matters (e.g. Succ and Pred), and also to
4503 -- be used to ensure that non-static folded things are not marked as
4504 -- being static (a check that is done right at the end).
4506 P_Root_Type := Root_Type (P_Type);
4507 P_Base_Type := Base_Type (P_Type);
4509 -- If the root type or base type is generic, then we cannot fold. This
4510 -- test is needed because subtypes of generic types are not always
4511 -- marked as being generic themselves (which seems odd???)
4513 if Is_Generic_Type (P_Root_Type)
4514 or else Is_Generic_Type (P_Base_Type)
4519 if Is_Scalar_Type (P_Type) then
4520 Static := Is_OK_Static_Subtype (P_Type);
4522 -- Array case. We enforce the constrained requirement of (RM 4.9(7-8))
4523 -- since we can't do anything with unconstrained arrays. In addition,
4524 -- only the First, Last and Length attributes are possibly static.
4525 -- In addition Component_Size is possibly foldable, even though it
4526 -- can never be static.
4528 -- Definite, Has_Discriminants, Type_Class and Unconstrained_Array are
4529 -- again exceptions, because they apply as well to unconstrained types.
4531 elsif Id = Attribute_Definite
4533 Id = Attribute_Has_Discriminants
4535 Id = Attribute_Type_Class
4537 Id = Attribute_Unconstrained_Array
4542 if not Is_Constrained (P_Type)
4543 or else (Id /= Attribute_Component_Size and then
4544 Id /= Attribute_First and then
4545 Id /= Attribute_Last and then
4546 Id /= Attribute_Length)
4552 -- The rules in (RM 4.9(7,8)) require a static array, but as in the
4553 -- scalar case, we hold off on enforcing staticness, since there are
4554 -- cases which we can fold at compile time even though they are not
4555 -- static (e.g. 'Length applied to a static index, even though other
4556 -- non-static indexes make the array type non-static). This is only
4557 -- an optimization, but it falls out essentially free, so why not.
4558 -- Again we compute the variable Static for easy reference later
4559 -- (note that no array attributes are static in Ada 83).
4567 N := First_Index (P_Type);
4568 while Present (N) loop
4569 Static := Static and then Is_Static_Subtype (Etype (N));
4571 -- If however the index type is generic, attributes cannot
4574 if Is_Generic_Type (Etype (N))
4575 and then Id /= Attribute_Component_Size
4585 -- Check any expressions that are present. Note that these expressions,
4586 -- depending on the particular attribute type, are either part of the
4587 -- attribute designator, or they are arguments in a case where the
4588 -- attribute reference returns a function. In the latter case, the
4589 -- rule in (RM 4.9(22)) applies and in particular requires the type
4590 -- of the expressions to be scalar in order for the attribute to be
4591 -- considered to be static.
4598 while Present (E) loop
4600 -- If expression is not static, then the attribute reference
4601 -- result certainly cannot be static.
4603 if not Is_Static_Expression (E) then
4607 -- If the result is not known at compile time, or is not of
4608 -- a scalar type, then the result is definitely not static,
4609 -- so we can quit now.
4611 if not Compile_Time_Known_Value (E)
4612 or else not Is_Scalar_Type (Etype (E))
4614 -- An odd special case, if this is a Pos attribute, this
4615 -- is where we need to apply a range check since it does
4616 -- not get done anywhere else.
4618 if Id = Attribute_Pos then
4619 if Is_Integer_Type (Etype (E)) then
4620 Apply_Range_Check (E, Etype (N));
4627 -- If the expression raises a constraint error, then so does
4628 -- the attribute reference. We keep going in this case because
4629 -- we are still interested in whether the attribute reference
4630 -- is static even if it is not static.
4632 elsif Raises_Constraint_Error (E) then
4633 Set_Raises_Constraint_Error (N);
4639 if Raises_Constraint_Error (Prefix (N)) then
4644 -- Deal with the case of a static attribute reference that raises
4645 -- constraint error. The Raises_Constraint_Error flag will already
4646 -- have been set, and the Static flag shows whether the attribute
4647 -- reference is static. In any case we certainly can't fold such an
4648 -- attribute reference.
4650 -- Note that the rewriting of the attribute node with the constraint
4651 -- error node is essential in this case, because otherwise Gigi might
4652 -- blow up on one of the attributes it never expects to see.
4654 -- The constraint_error node must have the type imposed by the context,
4655 -- to avoid spurious errors in the enclosing expression.
4657 if Raises_Constraint_Error (N) then
4659 Make_Raise_Constraint_Error (Sloc (N),
4660 Reason => CE_Range_Check_Failed);
4661 Set_Etype (CE_Node, Etype (N));
4662 Set_Raises_Constraint_Error (CE_Node);
4664 Rewrite (N, Relocate_Node (CE_Node));
4665 Set_Is_Static_Expression (N, Static);
4669 -- At this point we have a potentially foldable attribute reference.
4670 -- If Static is set, then the attribute reference definitely obeys
4671 -- the requirements in (RM 4.9(7,8,22)), and it definitely can be
4672 -- folded. If Static is not set, then the attribute may or may not
4673 -- be foldable, and the individual attribute processing routines
4674 -- test Static as required in cases where it makes a difference.
4676 -- In the case where Static is not set, we do know that all the
4677 -- expressions present are at least known at compile time (we
4678 -- assumed above that if this was not the case, then there was
4679 -- no hope of static evaluation). However, we did not require
4680 -- that the bounds of the prefix type be compile time known,
4681 -- let alone static). That's because there are many attributes
4682 -- that can be computed at compile time on non-static subtypes,
4683 -- even though such references are not static expressions.
4691 when Attribute_Adjacent =>
4694 (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
4700 when Attribute_Aft =>
4701 Fold_Uint (N, UI_From_Int (Aft_Value), True);
4707 when Attribute_Alignment => Alignment_Block : declare
4708 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
4711 -- Fold if alignment is set and not otherwise
4713 if Known_Alignment (P_TypeA) then
4714 Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA));
4716 end Alignment_Block;
4722 -- Can only be folded in No_Ast_Handler case
4724 when Attribute_AST_Entry =>
4725 if not Is_AST_Entry (P_Entity) then
4727 New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc));
4736 -- Bit can never be folded
4738 when Attribute_Bit =>
4745 -- Body_version can never be static
4747 when Attribute_Body_Version =>
4754 when Attribute_Ceiling =>
4756 Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)), Static);
4758 --------------------
4759 -- Component_Size --
4760 --------------------
4762 when Attribute_Component_Size =>
4763 if Known_Static_Component_Size (P_Type) then
4764 Fold_Uint (N, Component_Size (P_Type), False);
4771 when Attribute_Compose =>
4774 (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)),
4781 -- Constrained is never folded for now, there may be cases that
4782 -- could be handled at compile time. to be looked at later.
4784 when Attribute_Constrained =>
4791 when Attribute_Copy_Sign =>
4794 (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
4800 when Attribute_Delta =>
4801 Fold_Ureal (N, Delta_Value (P_Type), True);
4807 when Attribute_Definite =>
4812 if Is_Indefinite_Subtype (P_Entity) then
4813 Result := New_Occurrence_Of (Standard_False, Loc);
4815 Result := New_Occurrence_Of (Standard_True, Loc);
4818 Rewrite (N, Result);
4819 Analyze_And_Resolve (N, Standard_Boolean);
4826 when Attribute_Denorm =>
4828 (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True);
4834 when Attribute_Digits =>
4835 Fold_Uint (N, Digits_Value (P_Type), True);
4841 when Attribute_Emax =>
4843 -- Ada 83 attribute is defined as (RM83 3.5.8)
4845 -- T'Emax = 4 * T'Mantissa
4847 Fold_Uint (N, 4 * Mantissa, True);
4853 when Attribute_Enum_Rep =>
4855 -- For an enumeration type with a non-standard representation
4856 -- use the Enumeration_Rep field of the proper constant. Note
4857 -- that this would not work for types Character/Wide_Character,
4858 -- since no real entities are created for the enumeration
4859 -- literals, but that does not matter since these two types
4860 -- do not have non-standard representations anyway.
4862 if Is_Enumeration_Type (P_Type)
4863 and then Has_Non_Standard_Rep (P_Type)
4865 Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static);
4867 -- For enumeration types with standard representations and all
4868 -- other cases (i.e. all integer and modular types), Enum_Rep
4869 -- is equivalent to Pos.
4872 Fold_Uint (N, Expr_Value (E1), Static);
4879 when Attribute_Epsilon =>
4881 -- Ada 83 attribute is defined as (RM83 3.5.8)
4883 -- T'Epsilon = 2.0**(1 - T'Mantissa)
4885 Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
4891 when Attribute_Exponent =>
4893 Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)), Static);
4899 when Attribute_First => First_Attr :
4903 if Compile_Time_Known_Value (Lo_Bound) then
4904 if Is_Real_Type (P_Type) then
4905 Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
4907 Fold_Uint (N, Expr_Value (Lo_Bound), Static);
4916 when Attribute_Fixed_Value =>
4923 when Attribute_Floor =>
4925 Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)), Static);
4931 when Attribute_Fore =>
4932 if Compile_Time_Known_Bounds (P_Type) then
4933 Fold_Uint (N, UI_From_Int (Fore_Value), Static);
4940 when Attribute_Fraction =>
4942 Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static);
4944 -----------------------
4945 -- Has_Discriminants --
4946 -----------------------
4948 when Attribute_Has_Discriminants =>
4953 if Has_Discriminants (P_Entity) then
4954 Result := New_Occurrence_Of (Standard_True, Loc);
4956 Result := New_Occurrence_Of (Standard_False, Loc);
4959 Rewrite (N, Result);
4960 Analyze_And_Resolve (N, Standard_Boolean);
4967 when Attribute_Identity =>
4974 -- Image is a scalar attribute, but is never static, because it is
4975 -- not a static function (having a non-scalar argument (RM 4.9(22))
4977 when Attribute_Image =>
4984 -- Img is a scalar attribute, but is never static, because it is
4985 -- not a static function (having a non-scalar argument (RM 4.9(22))
4987 when Attribute_Img =>
4994 when Attribute_Integer_Value =>
5001 when Attribute_Large =>
5003 -- For fixed-point, we use the identity:
5005 -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small
5007 if Is_Fixed_Point_Type (P_Type) then
5009 Make_Op_Multiply (Loc,
5011 Make_Op_Subtract (Loc,
5015 Make_Real_Literal (Loc, Ureal_2),
5017 Make_Attribute_Reference (Loc,
5019 Attribute_Name => Name_Mantissa)),
5020 Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
5023 Make_Real_Literal (Loc, Small_Value (Entity (P)))));
5025 Analyze_And_Resolve (N, C_Type);
5027 -- Floating-point (Ada 83 compatibility)
5030 -- Ada 83 attribute is defined as (RM83 3.5.8)
5032 -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
5036 -- T'Emax = 4 * T'Mantissa
5039 Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
5047 when Attribute_Last => Last :
5051 if Compile_Time_Known_Value (Hi_Bound) then
5052 if Is_Real_Type (P_Type) then
5053 Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
5055 Fold_Uint (N, Expr_Value (Hi_Bound), Static);
5064 when Attribute_Leading_Part =>
5066 Eval_Fat.Leading_Part
5067 (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
5073 when Attribute_Length => Length : declare
5077 -- In the case of a generic index type, the bounds may
5078 -- appear static but the computation is not meaningful,
5079 -- and may generate a spurious warning.
5081 Ind := First_Index (P_Type);
5083 while Present (Ind) loop
5084 if Is_Generic_Type (Etype (Ind)) then
5093 if Compile_Time_Known_Value (Lo_Bound)
5094 and then Compile_Time_Known_Value (Hi_Bound)
5097 UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
5106 when Attribute_Machine =>
5109 (P_Root_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
5116 when Attribute_Machine_Emax =>
5117 Float_Attribute_Universal_Integer (
5125 AAMPL_Machine_Emax);
5131 when Attribute_Machine_Emin =>
5132 Float_Attribute_Universal_Integer (
5140 AAMPL_Machine_Emin);
5142 ----------------------
5143 -- Machine_Mantissa --
5144 ----------------------
5146 when Attribute_Machine_Mantissa =>
5147 Float_Attribute_Universal_Integer (
5148 IEEES_Machine_Mantissa,
5149 IEEEL_Machine_Mantissa,
5150 IEEEX_Machine_Mantissa,
5151 VAXFF_Machine_Mantissa,
5152 VAXDF_Machine_Mantissa,
5153 VAXGF_Machine_Mantissa,
5154 AAMPS_Machine_Mantissa,
5155 AAMPL_Machine_Mantissa);
5157 -----------------------
5158 -- Machine_Overflows --
5159 -----------------------
5161 when Attribute_Machine_Overflows =>
5163 -- Always true for fixed-point
5165 if Is_Fixed_Point_Type (P_Type) then
5166 Fold_Uint (N, True_Value, True);
5168 -- Floating point case
5172 UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
5180 when Attribute_Machine_Radix =>
5181 if Is_Fixed_Point_Type (P_Type) then
5182 if Is_Decimal_Fixed_Point_Type (P_Type)
5183 and then Machine_Radix_10 (P_Type)
5185 Fold_Uint (N, Uint_10, True);
5187 Fold_Uint (N, Uint_2, True);
5190 -- All floating-point type always have radix 2
5193 Fold_Uint (N, Uint_2, True);
5196 --------------------
5197 -- Machine_Rounds --
5198 --------------------
5200 when Attribute_Machine_Rounds =>
5202 -- Always False for fixed-point
5204 if Is_Fixed_Point_Type (P_Type) then
5205 Fold_Uint (N, False_Value, True);
5207 -- Else yield proper floating-point result
5211 (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True);
5218 -- Note: Machine_Size is identical to Object_Size
5220 when Attribute_Machine_Size => Machine_Size : declare
5221 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
5224 if Known_Esize (P_TypeA) then
5225 Fold_Uint (N, Esize (P_TypeA), True);
5233 when Attribute_Mantissa =>
5235 -- Fixed-point mantissa
5237 if Is_Fixed_Point_Type (P_Type) then
5239 -- Compile time foldable case
5241 if Compile_Time_Known_Value (Type_Low_Bound (P_Type))
5243 Compile_Time_Known_Value (Type_High_Bound (P_Type))
5245 -- The calculation of the obsolete Ada 83 attribute Mantissa
5246 -- is annoying, because of AI00143, quoted here:
5248 -- !question 84-01-10
5250 -- Consider the model numbers for F:
5252 -- type F is delta 1.0 range -7.0 .. 8.0;
5254 -- The wording requires that F'MANTISSA be the SMALLEST
5255 -- integer number for which each bound of the specified
5256 -- range is either a model number or lies at most small
5257 -- distant from a model number. This means F'MANTISSA
5258 -- is required to be 3 since the range -7.0 .. 7.0 fits
5259 -- in 3 signed bits, and 8 is "at most" 1.0 from a model
5260 -- number, namely, 7. Is this analysis correct? Note that
5261 -- this implies the upper bound of the range is not
5262 -- represented as a model number.
5264 -- !response 84-03-17
5266 -- The analysis is correct. The upper and lower bounds for
5267 -- a fixed point type can lie outside the range of model
5278 LBound := Expr_Value_R (Type_Low_Bound (P_Type));
5279 UBound := Expr_Value_R (Type_High_Bound (P_Type));
5280 Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
5281 Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
5283 -- If the Bound is exactly a model number, i.e. a multiple
5284 -- of Small, then we back it off by one to get the integer
5285 -- value that must be representable.
5287 if Small_Value (P_Type) * Max_Man = Bound then
5288 Max_Man := Max_Man - 1;
5291 -- Now find corresponding size = Mantissa value
5294 while 2 ** Siz < Max_Man loop
5298 Fold_Uint (N, Siz, True);
5302 -- The case of dynamic bounds cannot be evaluated at compile
5303 -- time. Instead we use a runtime routine (see Exp_Attr).
5308 -- Floating-point Mantissa
5311 Fold_Uint (N, Mantissa, True);
5318 when Attribute_Max => Max :
5320 if Is_Real_Type (P_Type) then
5322 (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
5324 Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
5328 ----------------------------------
5329 -- Max_Size_In_Storage_Elements --
5330 ----------------------------------
5332 -- Max_Size_In_Storage_Elements is simply the Size rounded up to a
5333 -- Storage_Unit boundary. We can fold any cases for which the size
5334 -- is known by the front end.
5336 when Attribute_Max_Size_In_Storage_Elements =>
5337 if Known_Esize (P_Type) then
5339 (Esize (P_Type) + System_Storage_Unit - 1) /
5340 System_Storage_Unit,
5344 --------------------
5345 -- Mechanism_Code --
5346 --------------------
5348 when Attribute_Mechanism_Code =>
5352 Mech : Mechanism_Type;
5356 Mech := Mechanism (P_Entity);
5359 Val := UI_To_Int (Expr_Value (E1));
5361 Formal := First_Formal (P_Entity);
5362 for J in 1 .. Val - 1 loop
5363 Next_Formal (Formal);
5365 Mech := Mechanism (Formal);
5369 Fold_Uint (N, UI_From_Int (Int (-Mech)), True);
5377 when Attribute_Min => Min :
5379 if Is_Real_Type (P_Type) then
5381 (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
5383 Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
5391 when Attribute_Model =>
5393 Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)), Static);
5399 when Attribute_Model_Emin =>
5400 Float_Attribute_Universal_Integer (
5414 when Attribute_Model_Epsilon =>
5415 Float_Attribute_Universal_Real (
5416 IEEES_Model_Epsilon'Universal_Literal_String,
5417 IEEEL_Model_Epsilon'Universal_Literal_String,
5418 IEEEX_Model_Epsilon'Universal_Literal_String,
5419 VAXFF_Model_Epsilon'Universal_Literal_String,
5420 VAXDF_Model_Epsilon'Universal_Literal_String,
5421 VAXGF_Model_Epsilon'Universal_Literal_String,
5422 AAMPS_Model_Epsilon'Universal_Literal_String,
5423 AAMPL_Model_Epsilon'Universal_Literal_String);
5425 --------------------
5426 -- Model_Mantissa --
5427 --------------------
5429 when Attribute_Model_Mantissa =>
5430 Float_Attribute_Universal_Integer (
5431 IEEES_Model_Mantissa,
5432 IEEEL_Model_Mantissa,
5433 IEEEX_Model_Mantissa,
5434 VAXFF_Model_Mantissa,
5435 VAXDF_Model_Mantissa,
5436 VAXGF_Model_Mantissa,
5437 AAMPS_Model_Mantissa,
5438 AAMPL_Model_Mantissa);
5444 when Attribute_Model_Small =>
5445 Float_Attribute_Universal_Real (
5446 IEEES_Model_Small'Universal_Literal_String,
5447 IEEEL_Model_Small'Universal_Literal_String,
5448 IEEEX_Model_Small'Universal_Literal_String,
5449 VAXFF_Model_Small'Universal_Literal_String,
5450 VAXDF_Model_Small'Universal_Literal_String,
5451 VAXGF_Model_Small'Universal_Literal_String,
5452 AAMPS_Model_Small'Universal_Literal_String,
5453 AAMPL_Model_Small'Universal_Literal_String);
5459 when Attribute_Modulus =>
5460 Fold_Uint (N, Modulus (P_Type), True);
5462 --------------------
5463 -- Null_Parameter --
5464 --------------------
5466 -- Cannot fold, we know the value sort of, but the whole point is
5467 -- that there is no way to talk about this imaginary value except
5468 -- by using the attribute, so we leave it the way it is.
5470 when Attribute_Null_Parameter =>
5477 -- The Object_Size attribute for a type returns the Esize of the
5478 -- type and can be folded if this value is known.
5480 when Attribute_Object_Size => Object_Size : declare
5481 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
5484 if Known_Esize (P_TypeA) then
5485 Fold_Uint (N, Esize (P_TypeA), True);
5489 -------------------------
5490 -- Passed_By_Reference --
5491 -------------------------
5493 -- Scalar types are never passed by reference
5495 when Attribute_Passed_By_Reference =>
5496 Fold_Uint (N, False_Value, True);
5502 when Attribute_Pos =>
5503 Fold_Uint (N, Expr_Value (E1), True);
5509 when Attribute_Pred => Pred :
5511 -- Floating-point case
5513 if Is_Floating_Point_Type (P_Type) then
5515 Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)), Static);
5519 elsif Is_Fixed_Point_Type (P_Type) then
5521 Expr_Value_R (E1) - Small_Value (P_Type), True);
5523 -- Modular integer case (wraps)
5525 elsif Is_Modular_Integer_Type (P_Type) then
5526 Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
5528 -- Other scalar cases
5531 pragma Assert (Is_Scalar_Type (P_Type));
5533 if Is_Enumeration_Type (P_Type)
5534 and then Expr_Value (E1) =
5535 Expr_Value (Type_Low_Bound (P_Base_Type))
5537 Apply_Compile_Time_Constraint_Error
5538 (N, "Pred of `&''First`",
5539 CE_Overflow_Check_Failed,
5541 Warn => not Static);
5547 Fold_Uint (N, Expr_Value (E1) - 1, Static);
5555 -- No processing required, because by this stage, Range has been
5556 -- replaced by First .. Last, so this branch can never be taken.
5558 when Attribute_Range =>
5559 raise Program_Error;
5565 when Attribute_Range_Length =>
5568 if Compile_Time_Known_Value (Hi_Bound)
5569 and then Compile_Time_Known_Value (Lo_Bound)
5573 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
5581 when Attribute_Remainder =>
5584 (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)),
5591 when Attribute_Round => Round :
5597 -- First we get the (exact result) in units of small
5599 Sr := Expr_Value_R (E1) / Small_Value (C_Type);
5601 -- Now round that exactly to an integer
5603 Si := UR_To_Uint (Sr);
5605 -- Finally the result is obtained by converting back to real
5607 Fold_Ureal (N, Si * Small_Value (C_Type), Static);
5614 when Attribute_Rounding =>
5616 Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
5622 when Attribute_Safe_Emax =>
5623 Float_Attribute_Universal_Integer (
5637 when Attribute_Safe_First =>
5638 Float_Attribute_Universal_Real (
5639 IEEES_Safe_First'Universal_Literal_String,
5640 IEEEL_Safe_First'Universal_Literal_String,
5641 IEEEX_Safe_First'Universal_Literal_String,
5642 VAXFF_Safe_First'Universal_Literal_String,
5643 VAXDF_Safe_First'Universal_Literal_String,
5644 VAXGF_Safe_First'Universal_Literal_String,
5645 AAMPS_Safe_First'Universal_Literal_String,
5646 AAMPL_Safe_First'Universal_Literal_String);
5652 when Attribute_Safe_Large =>
5653 if Is_Fixed_Point_Type (P_Type) then
5655 (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
5657 Float_Attribute_Universal_Real (
5658 IEEES_Safe_Large'Universal_Literal_String,
5659 IEEEL_Safe_Large'Universal_Literal_String,
5660 IEEEX_Safe_Large'Universal_Literal_String,
5661 VAXFF_Safe_Large'Universal_Literal_String,
5662 VAXDF_Safe_Large'Universal_Literal_String,
5663 VAXGF_Safe_Large'Universal_Literal_String,
5664 AAMPS_Safe_Large'Universal_Literal_String,
5665 AAMPL_Safe_Large'Universal_Literal_String);
5672 when Attribute_Safe_Last =>
5673 Float_Attribute_Universal_Real (
5674 IEEES_Safe_Last'Universal_Literal_String,
5675 IEEEL_Safe_Last'Universal_Literal_String,
5676 IEEEX_Safe_Last'Universal_Literal_String,
5677 VAXFF_Safe_Last'Universal_Literal_String,
5678 VAXDF_Safe_Last'Universal_Literal_String,
5679 VAXGF_Safe_Last'Universal_Literal_String,
5680 AAMPS_Safe_Last'Universal_Literal_String,
5681 AAMPL_Safe_Last'Universal_Literal_String);
5687 when Attribute_Safe_Small =>
5689 -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant
5690 -- for fixed-point, since is the same as Small, but we implement
5691 -- it for backwards compatibility.
5693 if Is_Fixed_Point_Type (P_Type) then
5694 Fold_Ureal (N, Small_Value (P_Type), Static);
5696 -- Ada 83 Safe_Small for floating-point cases
5699 Float_Attribute_Universal_Real (
5700 IEEES_Safe_Small'Universal_Literal_String,
5701 IEEEL_Safe_Small'Universal_Literal_String,
5702 IEEEX_Safe_Small'Universal_Literal_String,
5703 VAXFF_Safe_Small'Universal_Literal_String,
5704 VAXDF_Safe_Small'Universal_Literal_String,
5705 VAXGF_Safe_Small'Universal_Literal_String,
5706 AAMPS_Safe_Small'Universal_Literal_String,
5707 AAMPL_Safe_Small'Universal_Literal_String);
5714 when Attribute_Scale =>
5715 Fold_Uint (N, Scale_Value (P_Type), True);
5721 when Attribute_Scaling =>
5724 (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
5730 when Attribute_Signed_Zeros =>
5732 (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static);
5738 -- Size attribute returns the RM size. All scalar types can be folded,
5739 -- as well as any types for which the size is known by the front end,
5740 -- including any type for which a size attribute is specified.
5742 when Attribute_Size | Attribute_VADS_Size => Size : declare
5743 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
5746 if RM_Size (P_TypeA) /= Uint_0 then
5750 if Id = Attribute_VADS_Size or else Use_VADS_Size then
5752 S : constant Node_Id := Size_Clause (P_TypeA);
5755 -- If a size clause applies, then use the size from it.
5756 -- This is one of the rare cases where we can use the
5757 -- Size_Clause field for a subtype when Has_Size_Clause
5758 -- is False. Consider:
5760 -- type x is range 1 .. 64; g
5761 -- for x'size use 12;
5762 -- subtype y is x range 0 .. 3;
5764 -- Here y has a size clause inherited from x, but normally
5765 -- it does not apply, and y'size is 2. However, y'VADS_Size
5766 -- is indeed 12 and not 2.
5769 and then Is_OK_Static_Expression (Expression (S))
5771 Fold_Uint (N, Expr_Value (Expression (S)), True);
5773 -- If no size is specified, then we simply use the object
5774 -- size in the VADS_Size case (e.g. Natural'Size is equal
5775 -- to Integer'Size, not one less).
5778 Fold_Uint (N, Esize (P_TypeA), True);
5782 -- Normal case (Size) in which case we want the RM_Size
5787 Static and then Is_Discrete_Type (P_TypeA));
5796 when Attribute_Small =>
5798 -- The floating-point case is present only for Ada 83 compatability.
5799 -- Note that strictly this is an illegal addition, since we are
5800 -- extending an Ada 95 defined attribute, but we anticipate an
5801 -- ARG ruling that will permit this.
5803 if Is_Floating_Point_Type (P_Type) then
5805 -- Ada 83 attribute is defined as (RM83 3.5.8)
5807 -- T'Small = 2.0**(-T'Emax - 1)
5811 -- T'Emax = 4 * T'Mantissa
5813 Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
5815 -- Normal Ada 95 fixed-point case
5818 Fold_Ureal (N, Small_Value (P_Type), True);
5825 when Attribute_Succ => Succ :
5827 -- Floating-point case
5829 if Is_Floating_Point_Type (P_Type) then
5831 Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)), Static);
5835 elsif Is_Fixed_Point_Type (P_Type) then
5837 Expr_Value_R (E1) + Small_Value (P_Type), Static);
5839 -- Modular integer case (wraps)
5841 elsif Is_Modular_Integer_Type (P_Type) then
5842 Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
5844 -- Other scalar cases
5847 pragma Assert (Is_Scalar_Type (P_Type));
5849 if Is_Enumeration_Type (P_Type)
5850 and then Expr_Value (E1) =
5851 Expr_Value (Type_High_Bound (P_Base_Type))
5853 Apply_Compile_Time_Constraint_Error
5854 (N, "Succ of `&''Last`",
5855 CE_Overflow_Check_Failed,
5857 Warn => not Static);
5862 Fold_Uint (N, Expr_Value (E1) + 1, Static);
5871 when Attribute_Truncation =>
5873 Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)), Static);
5879 when Attribute_Type_Class => Type_Class : declare
5880 Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
5884 if Is_RTE (P_Root_Type, RE_Address) then
5885 Id := RE_Type_Class_Address;
5887 elsif Is_Enumeration_Type (Typ) then
5888 Id := RE_Type_Class_Enumeration;
5890 elsif Is_Integer_Type (Typ) then
5891 Id := RE_Type_Class_Integer;
5893 elsif Is_Fixed_Point_Type (Typ) then
5894 Id := RE_Type_Class_Fixed_Point;
5896 elsif Is_Floating_Point_Type (Typ) then
5897 Id := RE_Type_Class_Floating_Point;
5899 elsif Is_Array_Type (Typ) then
5900 Id := RE_Type_Class_Array;
5902 elsif Is_Record_Type (Typ) then
5903 Id := RE_Type_Class_Record;
5905 elsif Is_Access_Type (Typ) then
5906 Id := RE_Type_Class_Access;
5908 elsif Is_Enumeration_Type (Typ) then
5909 Id := RE_Type_Class_Enumeration;
5911 elsif Is_Task_Type (Typ) then
5912 Id := RE_Type_Class_Task;
5914 -- We treat protected types like task types. It would make more
5915 -- sense to have another enumeration value, but after all the
5916 -- whole point of this feature is to be exactly DEC compatible,
5917 -- and changing the type Type_Clas would not meet this requirement.
5919 elsif Is_Protected_Type (Typ) then
5920 Id := RE_Type_Class_Task;
5922 -- Not clear if there are any other possibilities, but if there
5923 -- are, then we will treat them as the address case.
5926 Id := RE_Type_Class_Address;
5929 Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
5933 -----------------------
5934 -- Unbiased_Rounding --
5935 -----------------------
5937 when Attribute_Unbiased_Rounding =>
5939 Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)),
5942 -------------------------
5943 -- Unconstrained_Array --
5944 -------------------------
5946 when Attribute_Unconstrained_Array => Unconstrained_Array : declare
5947 Typ : constant Entity_Id := Underlying_Type (P_Type);
5950 if Is_Array_Type (P_Type)
5951 and then not Is_Constrained (Typ)
5953 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5955 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5958 -- Analyze and resolve as boolean, note that this attribute is
5959 -- a static attribute in GNAT.
5961 Analyze_And_Resolve (N, Standard_Boolean);
5963 end Unconstrained_Array;
5969 -- Processing is shared with Size
5975 when Attribute_Val => Val :
5977 if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
5979 Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
5981 Apply_Compile_Time_Constraint_Error
5982 (N, "Val expression out of range",
5983 CE_Range_Check_Failed,
5984 Warn => not Static);
5990 Fold_Uint (N, Expr_Value (E1), Static);
5998 -- The Value_Size attribute for a type returns the RM size of the
5999 -- type. This an always be folded for scalar types, and can also
6000 -- be folded for non-scalar types if the size is set.
6002 when Attribute_Value_Size => Value_Size : declare
6003 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
6006 if RM_Size (P_TypeA) /= Uint_0 then
6007 Fold_Uint (N, RM_Size (P_TypeA), True);
6016 -- Version can never be static
6018 when Attribute_Version =>
6025 -- Wide_Image is a scalar attribute, but is never static, because it
6026 -- is not a static function (having a non-scalar argument (RM 4.9(22))
6028 when Attribute_Wide_Image =>
6035 -- Processing for Wide_Width is combined with Width
6041 -- This processing also handles the case of Wide_Width
6043 when Attribute_Width | Attribute_Wide_Width => Width :
6045 if Compile_Time_Known_Bounds (P_Type) then
6047 -- Floating-point types
6049 if Is_Floating_Point_Type (P_Type) then
6051 -- Width is zero for a null range (RM 3.5 (38))
6053 if Expr_Value_R (Type_High_Bound (P_Type)) <
6054 Expr_Value_R (Type_Low_Bound (P_Type))
6056 Fold_Uint (N, Uint_0, True);
6059 -- For floating-point, we have +N.dddE+nnn where length
6060 -- of ddd is determined by type'Digits - 1, but is one
6061 -- if Digits is one (RM 3.5 (33)).
6063 -- nnn is set to 2 for Short_Float and Float (32 bit
6064 -- floats), and 3 for Long_Float and Long_Long_Float.
6065 -- This is not quite right, but is good enough.
6069 Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
6072 if Esize (P_Type) <= 32 then
6078 Fold_Uint (N, UI_From_Int (Len), True);
6082 -- Fixed-point types
6084 elsif Is_Fixed_Point_Type (P_Type) then
6086 -- Width is zero for a null range (RM 3.5 (38))
6088 if Expr_Value (Type_High_Bound (P_Type)) <
6089 Expr_Value (Type_Low_Bound (P_Type))
6091 Fold_Uint (N, Uint_0, True);
6093 -- The non-null case depends on the specific real type
6096 -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
6099 (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True);
6106 R : constant Entity_Id := Root_Type (P_Type);
6107 Lo : constant Uint :=
6108 Expr_Value (Type_Low_Bound (P_Type));
6109 Hi : constant Uint :=
6110 Expr_Value (Type_High_Bound (P_Type));
6123 -- Width for types derived from Standard.Character
6124 -- and Standard.Wide_Character.
6126 elsif R = Standard_Character
6127 or else R = Standard_Wide_Character
6131 -- Set W larger if needed
6133 for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
6135 -- Assume all wide-character escape sequences are
6136 -- same length, so we can quit when we reach one.
6139 if Id = Attribute_Wide_Width then
6140 W := Int'Max (W, 3);
6143 W := Int'Max (W, Length_Wide);
6148 C := Character'Val (J);
6150 -- Test for all cases where Character'Image
6151 -- yields an image that is longer than three
6152 -- characters. First the cases of Reserved_xxx
6153 -- names (length = 12).
6156 when Reserved_128 | Reserved_129 |
6157 Reserved_132 | Reserved_153
6161 when BS | HT | LF | VT | FF | CR |
6162 SO | SI | EM | FS | GS | RS |
6163 US | RI | MW | ST | PM
6167 when NUL | SOH | STX | ETX | EOT |
6168 ENQ | ACK | BEL | DLE | DC1 |
6169 DC2 | DC3 | DC4 | NAK | SYN |
6170 ETB | CAN | SUB | ESC | DEL |
6171 BPH | NBH | NEL | SSA | ESA |
6172 HTS | HTJ | VTS | PLD | PLU |
6173 SS2 | SS3 | DCS | PU1 | PU2 |
6174 STS | CCH | SPA | EPA | SOS |
6175 SCI | CSI | OSC | APC
6179 when Space .. Tilde |
6180 No_Break_Space .. LC_Y_Diaeresis
6185 W := Int'Max (W, Wt);
6189 -- Width for types derived from Standard.Boolean
6191 elsif R = Standard_Boolean then
6198 -- Width for integer types
6200 elsif Is_Integer_Type (P_Type) then
6201 T := UI_Max (abs Lo, abs Hi);
6209 -- Only remaining possibility is user declared enum type
6212 pragma Assert (Is_Enumeration_Type (P_Type));
6215 L := First_Literal (P_Type);
6217 while Present (L) loop
6219 -- Only pay attention to in range characters
6221 if Lo <= Enumeration_Pos (L)
6222 and then Enumeration_Pos (L) <= Hi
6224 -- For Width case, use decoded name
6226 if Id = Attribute_Width then
6227 Get_Decoded_Name_String (Chars (L));
6228 Wt := Nat (Name_Len);
6230 -- For Wide_Width, use encoded name, and then
6231 -- adjust for the encoding.
6234 Get_Name_String (Chars (L));
6236 -- Character literals are always of length 3
6238 if Name_Buffer (1) = 'Q' then
6241 -- Otherwise loop to adjust for upper/wide chars
6244 Wt := Nat (Name_Len);
6246 for J in 1 .. Name_Len loop
6247 if Name_Buffer (J) = 'U' then
6249 elsif Name_Buffer (J) = 'W' then
6256 W := Int'Max (W, Wt);
6263 Fold_Uint (N, UI_From_Int (W), True);
6269 -- The following attributes can never be folded, and furthermore we
6270 -- should not even have entered the case statement for any of these.
6271 -- Note that in some cases, the values have already been folded as
6272 -- a result of the processing in Analyze_Attribute.
6274 when Attribute_Abort_Signal |
6277 Attribute_Address_Size |
6278 Attribute_Asm_Input |
6279 Attribute_Asm_Output |
6281 Attribute_Bit_Order |
6282 Attribute_Bit_Position |
6283 Attribute_Callable |
6286 Attribute_Code_Address |
6288 Attribute_Default_Bit_Order |
6289 Attribute_Elaborated |
6290 Attribute_Elab_Body |
6291 Attribute_Elab_Spec |
6292 Attribute_External_Tag |
6293 Attribute_First_Bit |
6295 Attribute_Last_Bit |
6296 Attribute_Maximum_Alignment |
6298 Attribute_Partition_ID |
6299 Attribute_Pool_Address |
6300 Attribute_Position |
6302 Attribute_Storage_Pool |
6303 Attribute_Storage_Size |
6304 Attribute_Storage_Unit |
6306 Attribute_Target_Name |
6307 Attribute_Terminated |
6308 Attribute_To_Address |
6309 Attribute_UET_Address |
6310 Attribute_Unchecked_Access |
6311 Attribute_Universal_Literal_String |
6312 Attribute_Unrestricted_Access |
6315 Attribute_Wchar_T_Size |
6316 Attribute_Wide_Value |
6317 Attribute_Word_Size |
6320 raise Program_Error;
6324 -- At the end of the case, one more check. If we did a static evaluation
6325 -- so that the result is now a literal, then set Is_Static_Expression
6326 -- in the constant only if the prefix type is a static subtype. For
6327 -- non-static subtypes, the folding is still OK, but not static.
6329 -- An exception is the GNAT attribute Constrained_Array which is
6330 -- defined to be a static attribute in all cases.
6332 if Nkind (N) = N_Integer_Literal
6333 or else Nkind (N) = N_Real_Literal
6334 or else Nkind (N) = N_Character_Literal
6335 or else Nkind (N) = N_String_Literal
6336 or else (Is_Entity_Name (N)
6337 and then Ekind (Entity (N)) = E_Enumeration_Literal)
6339 Set_Is_Static_Expression (N, Static);
6341 -- If this is still an attribute reference, then it has not been folded
6342 -- and that means that its expressions are in a non-static context.
6344 elsif Nkind (N) = N_Attribute_Reference then
6347 -- Note: the else case not covered here are odd cases where the
6348 -- processing has transformed the attribute into something other
6349 -- than a constant. Nothing more to do in such cases.
6357 ------------------------------
6358 -- Is_Anonymous_Tagged_Base --
6359 ------------------------------
6361 function Is_Anonymous_Tagged_Base
6368 Anon = Current_Scope
6369 and then Is_Itype (Anon)
6370 and then Associated_Node_For_Itype (Anon) = Parent (Typ);
6371 end Is_Anonymous_Tagged_Base;
6373 -----------------------
6374 -- Resolve_Attribute --
6375 -----------------------
6377 procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
6378 Loc : constant Source_Ptr := Sloc (N);
6379 P : constant Node_Id := Prefix (N);
6380 Aname : constant Name_Id := Attribute_Name (N);
6381 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
6382 Btyp : constant Entity_Id := Base_Type (Typ);
6383 Index : Interp_Index;
6385 Nom_Subt : Entity_Id;
6388 -- If error during analysis, no point in continuing, except for
6389 -- array types, where we get better recovery by using unconstrained
6390 -- indices than nothing at all (see Check_Array_Type).
6393 and then Attr_Id /= Attribute_First
6394 and then Attr_Id /= Attribute_Last
6395 and then Attr_Id /= Attribute_Length
6396 and then Attr_Id /= Attribute_Range
6401 -- If attribute was universal type, reset to actual type
6403 if Etype (N) = Universal_Integer
6404 or else Etype (N) = Universal_Real
6409 -- Remaining processing depends on attribute
6417 -- For access attributes, if the prefix denotes an entity, it is
6418 -- interpreted as a name, never as a call. It may be overloaded,
6419 -- in which case resolution uses the profile of the context type.
6420 -- Otherwise prefix must be resolved.
6422 when Attribute_Access
6423 | Attribute_Unchecked_Access
6424 | Attribute_Unrestricted_Access =>
6426 if Is_Variable (P) then
6427 Note_Possible_Modification (P);
6430 if Is_Entity_Name (P) then
6431 if Is_Overloaded (P) then
6432 Get_First_Interp (P, Index, It);
6434 while Present (It.Nam) loop
6436 if Type_Conformant (Designated_Type (Typ), It.Nam) then
6437 Set_Entity (P, It.Nam);
6439 -- The prefix is definitely NOT overloaded anymore
6440 -- at this point, so we reset the Is_Overloaded
6441 -- flag to avoid any confusion when reanalyzing
6444 Set_Is_Overloaded (P, False);
6445 Generate_Reference (Entity (P), P);
6449 Get_Next_Interp (Index, It);
6452 -- If it is a subprogram name or a type, there is nothing
6455 elsif not Is_Overloadable (Entity (P))
6456 and then not Is_Type (Entity (P))
6461 Error_Msg_Name_1 := Aname;
6463 if not Is_Entity_Name (P) then
6466 elsif Is_Abstract (Entity (P))
6467 and then Is_Overloadable (Entity (P))
6469 Error_Msg_N ("prefix of % attribute cannot be abstract", P);
6470 Set_Etype (N, Any_Type);
6472 elsif Convention (Entity (P)) = Convention_Intrinsic then
6473 if Ekind (Entity (P)) = E_Enumeration_Literal then
6475 ("prefix of % attribute cannot be enumeration literal",
6479 ("prefix of % attribute cannot be intrinsic", P);
6482 Set_Etype (N, Any_Type);
6484 elsif Is_Thread_Body (Entity (P)) then
6486 ("prefix of % attribute cannot be a thread body", P);
6489 -- Assignments, return statements, components of aggregates,
6490 -- generic instantiations will require convention checks if
6491 -- the type is an access to subprogram. Given that there will
6492 -- also be accessibility checks on those, this is where the
6493 -- checks can eventually be centralized ???
6495 if Ekind (Btyp) = E_Access_Subprogram_Type then
6496 if Convention (Btyp) /= Convention (Entity (P)) then
6498 ("subprogram has invalid convention for context", P);
6501 Check_Subtype_Conformant
6502 (New_Id => Entity (P),
6503 Old_Id => Designated_Type (Btyp),
6507 if Attr_Id = Attribute_Unchecked_Access then
6508 Error_Msg_Name_1 := Aname;
6510 ("attribute% cannot be applied to a subprogram", P);
6512 elsif Aname = Name_Unrestricted_Access then
6513 null; -- Nothing to check
6515 -- Check the static accessibility rule of 3.10.2(32)
6516 -- In an instance body, if subprogram and type are both
6517 -- local, other rules prevent dangling references, and no
6518 -- warning is needed.
6520 elsif Attr_Id = Attribute_Access
6521 and then Subprogram_Access_Level (Entity (P))
6522 > Type_Access_Level (Btyp)
6524 if not In_Instance_Body then
6526 ("subprogram must not be deeper than access type",
6529 elsif Scope (Entity (P)) /= Scope (Btyp) then
6531 ("subprogram must not be deeper than access type?",
6534 ("Constraint_Error will be raised ?", P);
6535 Set_Raises_Constraint_Error (N);
6538 -- Check the restriction of 3.10.2(32) that disallows
6539 -- the type of the access attribute to be declared
6540 -- outside a generic body when the subprogram is declared
6541 -- within that generic body.
6543 elsif Enclosing_Generic_Body (Entity (P))
6544 /= Enclosing_Generic_Body (Btyp)
6547 ("access type must not be outside generic body", P);
6551 -- if this is a renaming, an inherited operation, or a
6552 -- subprogram instance, use the original entity.
6554 if Is_Entity_Name (P)
6555 and then Is_Overloadable (Entity (P))
6556 and then Present (Alias (Entity (P)))
6559 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
6562 elsif Nkind (P) = N_Selected_Component
6563 and then Is_Overloadable (Entity (Selector_Name (P)))
6565 -- Protected operation. If operation is overloaded, must
6566 -- disambiguate. Prefix that denotes protected object itself
6567 -- is resolved with its own type.
6569 if Attr_Id = Attribute_Unchecked_Access then
6570 Error_Msg_Name_1 := Aname;
6572 ("attribute% cannot be applied to protected operation", P);
6575 Resolve (Prefix (P));
6576 Generate_Reference (Entity (Selector_Name (P)), P);
6578 elsif Is_Overloaded (P) then
6580 -- Use the designated type of the context to disambiguate.
6582 Index : Interp_Index;
6585 Get_First_Interp (P, Index, It);
6587 while Present (It.Typ) loop
6588 if Covers (Designated_Type (Typ), It.Typ) then
6589 Resolve (P, It.Typ);
6593 Get_Next_Interp (Index, It);
6600 -- X'Access is illegal if X denotes a constant and the access
6601 -- type is access-to-variable. Same for 'Unchecked_Access.
6602 -- The rule does not apply to 'Unrestricted_Access.
6604 if not (Ekind (Btyp) = E_Access_Subprogram_Type
6605 or else (Is_Record_Type (Btyp) and then
6606 Present (Corresponding_Remote_Type (Btyp)))
6607 or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
6608 or else Is_Access_Constant (Btyp)
6609 or else Is_Variable (P)
6610 or else Attr_Id = Attribute_Unrestricted_Access)
6612 if Comes_From_Source (N) then
6613 Error_Msg_N ("access-to-variable designates constant", P);
6617 if (Attr_Id = Attribute_Access
6619 Attr_Id = Attribute_Unchecked_Access)
6620 and then (Ekind (Btyp) = E_General_Access_Type
6621 or else Ekind (Btyp) = E_Anonymous_Access_Type)
6623 if Is_Dependent_Component_Of_Mutable_Object (P) then
6625 ("illegal attribute for discriminant-dependent component",
6629 -- Check the static matching rule of 3.10.2(27). The
6630 -- nominal subtype of the prefix must statically
6631 -- match the designated type.
6633 Nom_Subt := Etype (P);
6635 if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
6636 Nom_Subt := Etype (Nom_Subt);
6639 if Is_Tagged_Type (Designated_Type (Typ)) then
6641 -- If the attribute is in the context of an access
6642 -- parameter, then the prefix is allowed to be of
6643 -- the class-wide type (by AI-127).
6645 if Ekind (Typ) = E_Anonymous_Access_Type then
6646 if not Covers (Designated_Type (Typ), Nom_Subt)
6647 and then not Covers (Nom_Subt, Designated_Type (Typ))
6653 Desig := Designated_Type (Typ);
6655 if Is_Class_Wide_Type (Desig) then
6656 Desig := Etype (Desig);
6659 if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then
6664 ("type of prefix: & not compatible",
6667 ("\with &, the expected designated type",
6668 P, Designated_Type (Typ));
6673 elsif not Covers (Designated_Type (Typ), Nom_Subt)
6675 (not Is_Class_Wide_Type (Designated_Type (Typ))
6676 and then Is_Class_Wide_Type (Nom_Subt))
6679 ("type of prefix: & is not covered", P, Nom_Subt);
6681 ("\by &, the expected designated type" &
6682 " ('R'M 3.10.2 (27))", P, Designated_Type (Typ));
6685 if Is_Class_Wide_Type (Designated_Type (Typ))
6686 and then Has_Discriminants (Etype (Designated_Type (Typ)))
6687 and then Is_Constrained (Etype (Designated_Type (Typ)))
6688 and then Designated_Type (Typ) /= Nom_Subt
6690 Apply_Discriminant_Check
6691 (N, Etype (Designated_Type (Typ)));
6694 elsif not Subtypes_Statically_Match
6695 (Designated_Type (Base_Type (Typ)), Nom_Subt)
6697 not (Has_Discriminants (Designated_Type (Typ))
6700 (Designated_Type (Base_Type (Typ))))
6703 ("object subtype must statically match "
6704 & "designated subtype", P);
6706 if Is_Entity_Name (P)
6707 and then Is_Array_Type (Designated_Type (Typ))
6711 D : constant Node_Id := Declaration_Node (Entity (P));
6714 Error_Msg_N ("aliased object has explicit bounds?",
6716 Error_Msg_N ("\declare without bounds"
6717 & " (and with explicit initialization)?", D);
6718 Error_Msg_N ("\for use with unconstrained access?", D);
6723 -- Check the static accessibility rule of 3.10.2(28).
6724 -- Note that this check is not performed for the
6725 -- case of an anonymous access type, since the access
6726 -- attribute is always legal in such a context.
6728 if Attr_Id /= Attribute_Unchecked_Access
6729 and then Object_Access_Level (P) > Type_Access_Level (Btyp)
6730 and then Ekind (Btyp) = E_General_Access_Type
6732 -- In an instance, this is a runtime check, but one we
6733 -- know will fail, so generate an appropriate warning.
6735 if In_Instance_Body then
6737 ("?non-local pointer cannot point to local object", P);
6739 ("?Program_Error will be raised at run time", P);
6741 Make_Raise_Program_Error (Loc,
6742 Reason => PE_Accessibility_Check_Failed));
6748 ("non-local pointer cannot point to local object", P);
6750 if Is_Record_Type (Current_Scope)
6751 and then (Nkind (Parent (N)) =
6752 N_Discriminant_Association
6754 Nkind (Parent (N)) =
6755 N_Index_Or_Discriminant_Constraint)
6758 Indic : Node_Id := Parent (Parent (N));
6761 while Present (Indic)
6762 and then Nkind (Indic) /= N_Subtype_Indication
6764 Indic := Parent (Indic);
6767 if Present (Indic) then
6769 ("\use an access definition for" &
6770 " the access discriminant of&", N,
6771 Entity (Subtype_Mark (Indic)));
6779 if Ekind (Btyp) = E_Access_Protected_Subprogram_Type
6780 and then Is_Entity_Name (P)
6781 and then not Is_Protected_Type (Scope (Entity (P)))
6783 Error_Msg_N ("context requires a protected subprogram", P);
6785 elsif Ekind (Btyp) = E_Access_Subprogram_Type
6786 and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
6788 Error_Msg_N ("context requires a non-protected subprogram", P);
6791 -- The context cannot be a pool-specific type, but this is a
6792 -- legality rule, not a resolution rule, so it must be checked
6793 -- separately, after possibly disambiguation (see AI-245).
6795 if Ekind (Btyp) = E_Access_Type
6796 and then Attr_Id /= Attribute_Unrestricted_Access
6798 Wrong_Type (N, Typ);
6803 -- Check for incorrect atomic/volatile reference (RM C.6(12))
6805 if Attr_Id /= Attribute_Unrestricted_Access then
6806 if Is_Atomic_Object (P)
6807 and then not Is_Atomic (Designated_Type (Typ))
6810 ("access to atomic object cannot yield access-to-" &
6811 "non-atomic type", P);
6813 elsif Is_Volatile_Object (P)
6814 and then not Is_Volatile (Designated_Type (Typ))
6817 ("access to volatile object cannot yield access-to-" &
6818 "non-volatile type", P);
6826 -- Deal with resolving the type for Address attribute, overloading
6827 -- is not permitted here, since there is no context to resolve it.
6829 when Attribute_Address | Attribute_Code_Address =>
6831 -- To be safe, assume that if the address of a variable is taken,
6832 -- it may be modified via this address, so note modification.
6834 if Is_Variable (P) then
6835 Note_Possible_Modification (P);
6838 if Nkind (P) in N_Subexpr
6839 and then Is_Overloaded (P)
6841 Get_First_Interp (P, Index, It);
6842 Get_Next_Interp (Index, It);
6844 if Present (It.Nam) then
6845 Error_Msg_Name_1 := Aname;
6847 ("prefix of % attribute cannot be overloaded", N);
6852 if not Is_Entity_Name (P)
6853 or else not Is_Overloadable (Entity (P))
6855 if not Is_Task_Type (Etype (P))
6856 or else Nkind (P) = N_Explicit_Dereference
6862 -- If this is the name of a derived subprogram, or that of a
6863 -- generic actual, the address is that of the original entity.
6865 if Is_Entity_Name (P)
6866 and then Is_Overloadable (Entity (P))
6867 and then Present (Alias (Entity (P)))
6870 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
6877 -- Prefix of the AST_Entry attribute is an entry name which must
6878 -- not be resolved, since this is definitely not an entry call.
6880 when Attribute_AST_Entry =>
6887 -- Prefix of Body_Version attribute can be a subprogram name which
6888 -- must not be resolved, since this is not a call.
6890 when Attribute_Body_Version =>
6897 -- Prefix of Caller attribute is an entry name which must not
6898 -- be resolved, since this is definitely not an entry call.
6900 when Attribute_Caller =>
6907 -- Shares processing with Address attribute
6913 -- If the prefix of the Count attribute is an entry name it must not
6914 -- be resolved, since this is definitely not an entry call. However,
6915 -- if it is an element of an entry family, the index itself may
6916 -- have to be resolved because it can be a general expression.
6918 when Attribute_Count =>
6919 if Nkind (P) = N_Indexed_Component
6920 and then Is_Entity_Name (Prefix (P))
6923 Indx : constant Node_Id := First (Expressions (P));
6924 Fam : constant Entity_Id := Entity (Prefix (P));
6926 Resolve (Indx, Entry_Index_Type (Fam));
6927 Apply_Range_Check (Indx, Entry_Index_Type (Fam));
6935 -- Prefix of the Elaborated attribute is a subprogram name which
6936 -- must not be resolved, since this is definitely not a call. Note
6937 -- that it is a library unit, so it cannot be overloaded here.
6939 when Attribute_Elaborated =>
6942 --------------------
6943 -- Mechanism_Code --
6944 --------------------
6946 -- Prefix of the Mechanism_Code attribute is a function name
6947 -- which must not be resolved. Should we check for overloaded ???
6949 when Attribute_Mechanism_Code =>
6956 -- Most processing is done in sem_dist, after determining the
6957 -- context type. Node is rewritten as a conversion to a runtime call.
6959 when Attribute_Partition_ID =>
6960 Process_Partition_Id (N);
6963 when Attribute_Pool_Address =>
6970 -- We replace the Range attribute node with a range expression
6971 -- whose bounds are the 'First and 'Last attributes applied to the
6972 -- same prefix. The reason that we do this transformation here
6973 -- instead of in the expander is that it simplifies other parts of
6974 -- the semantic analysis which assume that the Range has been
6975 -- replaced; thus it must be done even when in semantic-only mode
6976 -- (note that the RM specifically mentions this equivalence, we
6977 -- take care that the prefix is only evaluated once).
6979 when Attribute_Range => Range_Attribute :
6984 function Check_Discriminated_Prival
6987 -- The range of a private component constrained by a
6988 -- discriminant is rewritten to make the discriminant
6989 -- explicit. This solves some complex visibility problems
6990 -- related to the use of privals.
6992 --------------------------------
6993 -- Check_Discriminated_Prival --
6994 --------------------------------
6996 function Check_Discriminated_Prival
7001 if Is_Entity_Name (N)
7002 and then Ekind (Entity (N)) = E_In_Parameter
7003 and then not Within_Init_Proc
7005 return Make_Identifier (Sloc (N), Chars (Entity (N)));
7007 return Duplicate_Subexpr (N);
7009 end Check_Discriminated_Prival;
7011 -- Start of processing for Range_Attribute
7014 if not Is_Entity_Name (P)
7015 or else not Is_Type (Entity (P))
7020 -- Check whether prefix is (renaming of) private component
7021 -- of protected type.
7023 if Is_Entity_Name (P)
7024 and then Comes_From_Source (N)
7025 and then Is_Array_Type (Etype (P))
7026 and then Number_Dimensions (Etype (P)) = 1
7027 and then (Ekind (Scope (Entity (P))) = E_Protected_Type
7029 Ekind (Scope (Scope (Entity (P)))) =
7033 Check_Discriminated_Prival
7034 (Type_Low_Bound (Etype (First_Index (Etype (P)))));
7037 Check_Discriminated_Prival
7038 (Type_High_Bound (Etype (First_Index (Etype (P)))));
7042 Make_Attribute_Reference (Loc,
7043 Prefix => Duplicate_Subexpr (P),
7044 Attribute_Name => Name_Last,
7045 Expressions => Expressions (N));
7048 Make_Attribute_Reference (Loc,
7050 Attribute_Name => Name_First,
7051 Expressions => Expressions (N));
7054 -- If the original was marked as Must_Not_Freeze (see code
7055 -- in Sem_Ch3.Make_Index), then make sure the rewriting
7056 -- does not freeze either.
7058 if Must_Not_Freeze (N) then
7059 Set_Must_Not_Freeze (HB);
7060 Set_Must_Not_Freeze (LB);
7061 Set_Must_Not_Freeze (Prefix (HB));
7062 Set_Must_Not_Freeze (Prefix (LB));
7065 if Raises_Constraint_Error (Prefix (N)) then
7067 -- Preserve Sloc of prefix in the new bounds, so that
7068 -- the posted warning can be removed if we are within
7069 -- unreachable code.
7071 Set_Sloc (LB, Sloc (Prefix (N)));
7072 Set_Sloc (HB, Sloc (Prefix (N)));
7075 Rewrite (N, Make_Range (Loc, LB, HB));
7076 Analyze_And_Resolve (N, Typ);
7078 -- Normally after resolving attribute nodes, Eval_Attribute
7079 -- is called to do any possible static evaluation of the node.
7080 -- However, here since the Range attribute has just been
7081 -- transformed into a range expression it is no longer an
7082 -- attribute node and therefore the call needs to be avoided
7083 -- and is accomplished by simply returning from the procedure.
7086 end Range_Attribute;
7092 -- Prefix must not be resolved in this case, since it is not a
7093 -- real entity reference. No action of any kind is require!
7095 when Attribute_UET_Address =>
7098 ----------------------
7099 -- Unchecked_Access --
7100 ----------------------
7102 -- Processing is shared with Access
7104 -------------------------
7105 -- Unrestricted_Access --
7106 -------------------------
7108 -- Processing is shared with Access
7114 -- Apply range check. Note that we did not do this during the
7115 -- analysis phase, since we wanted Eval_Attribute to have a
7116 -- chance at finding an illegal out of range value.
7118 when Attribute_Val =>
7120 -- Note that we do our own Eval_Attribute call here rather than
7121 -- use the common one, because we need to do processing after
7122 -- the call, as per above comment.
7126 -- Eval_Attribute may replace the node with a raise CE, or
7127 -- fold it to a constant. Obviously we only apply a scalar
7128 -- range check if this did not happen!
7130 if Nkind (N) = N_Attribute_Reference
7131 and then Attribute_Name (N) = Name_Val
7133 Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
7142 -- Prefix of Version attribute can be a subprogram name which
7143 -- must not be resolved, since this is not a call.
7145 when Attribute_Version =>
7148 ----------------------
7149 -- Other Attributes --
7150 ----------------------
7152 -- For other attributes, resolve prefix unless it is a type. If
7153 -- the attribute reference itself is a type name ('Base and 'Class)
7154 -- then this is only legal within a task or protected record.
7157 if not Is_Entity_Name (P)
7158 or else not Is_Type (Entity (P))
7163 -- If the attribute reference itself is a type name ('Base,
7164 -- 'Class) then this is only legal within a task or protected
7165 -- record. What is this all about ???
7167 if Is_Entity_Name (N)
7168 and then Is_Type (Entity (N))
7170 if Is_Concurrent_Type (Entity (N))
7171 and then In_Open_Scopes (Entity (P))
7176 ("invalid use of subtype name in expression or call", N);
7180 -- For attributes whose argument may be a string, complete
7181 -- resolution of argument now. This avoids premature expansion
7182 -- (and the creation of transient scopes) before the attribute
7183 -- reference is resolved.
7186 when Attribute_Value =>
7187 Resolve (First (Expressions (N)), Standard_String);
7189 when Attribute_Wide_Value =>
7190 Resolve (First (Expressions (N)), Standard_Wide_String);
7192 when others => null;
7196 -- Normally the Freezing is done by Resolve but sometimes the Prefix
7197 -- is not resolved, in which case the freezing must be done now.
7199 Freeze_Expression (P);
7201 -- Finally perform static evaluation on the attribute reference
7205 end Resolve_Attribute;