1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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_Util; use Exp_Util;
35 with Expander; use Expander;
36 with Freeze; use Freeze;
38 with Lib.Xref; use Lib.Xref;
39 with Namet; use Namet;
40 with Nlists; use Nlists;
41 with Nmake; use Nmake;
43 with Restrict; use Restrict;
44 with Rident; use Rident;
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;
69 package body Sem_Attr is
71 True_Value : constant Uint := Uint_1;
72 False_Value : constant Uint := Uint_0;
73 -- Synonyms to be used when these constants are used as Boolean values
75 Bad_Attribute : exception;
76 -- Exception raised if an error is detected during attribute processing,
77 -- used so that we can abandon the processing so we don't run into
78 -- trouble with cascaded errors.
80 -- The following array is the list of attributes defined in the Ada 83 RM
82 Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
88 Attribute_Constrained |
101 Attribute_Leading_Part |
103 Attribute_Machine_Emax |
104 Attribute_Machine_Emin |
105 Attribute_Machine_Mantissa |
106 Attribute_Machine_Overflows |
107 Attribute_Machine_Radix |
108 Attribute_Machine_Rounds |
114 Attribute_Safe_Emax |
115 Attribute_Safe_Large |
116 Attribute_Safe_Small |
119 Attribute_Storage_Size |
121 Attribute_Terminated |
124 Attribute_Width => True,
127 -----------------------
128 -- Local_Subprograms --
129 -----------------------
131 procedure Eval_Attribute (N : Node_Id);
132 -- Performs compile time evaluation of attributes where possible, leaving
133 -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately
134 -- set, and replacing the node with a literal node if the value can be
135 -- computed at compile time. All static attribute references are folded,
136 -- as well as a number of cases of non-static attributes that can always
137 -- be computed at compile time (e.g. floating-point model attributes that
138 -- are applied to non-static subtypes). Of course in such cases, the
139 -- Is_Static_Expression flag will not be set on the resulting literal.
140 -- Note that the only required action of this procedure is to catch the
141 -- static expression cases as described in the RM. Folding of other cases
142 -- is done where convenient, but some additional non-static folding is in
143 -- N_Expand_Attribute_Reference in cases where this is more convenient.
145 function Is_Anonymous_Tagged_Base
149 -- For derived tagged types that constrain parent discriminants we build
150 -- an anonymous unconstrained base type. We need to recognize the relation
151 -- between the two when analyzing an access attribute for a constrained
152 -- component, before the full declaration for Typ has been analyzed, and
153 -- where therefore the prefix of the attribute does not match the enclosing
156 -----------------------
157 -- Analyze_Attribute --
158 -----------------------
160 procedure Analyze_Attribute (N : Node_Id) is
161 Loc : constant Source_Ptr := Sloc (N);
162 Aname : constant Name_Id := Attribute_Name (N);
163 P : constant Node_Id := Prefix (N);
164 Exprs : constant List_Id := Expressions (N);
165 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
170 -- Type of prefix after analysis
172 P_Base_Type : Entity_Id;
173 -- Base type of prefix after analysis
175 -----------------------
176 -- Local Subprograms --
177 -----------------------
179 procedure Analyze_Access_Attribute;
180 -- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
181 -- Internally, Id distinguishes which of the three cases is involved.
183 procedure Check_Array_Or_Scalar_Type;
184 -- Common procedure used by First, Last, Range attribute to check
185 -- that the prefix is a constrained array or scalar type, or a name
186 -- of an array object, and that an argument appears only if appropriate
187 -- (i.e. only in the array case).
189 procedure Check_Array_Type;
190 -- Common semantic checks for all array attributes. Checks that the
191 -- prefix is a constrained array type or the name of an array object.
192 -- The error message for non-arrays is specialized appropriately.
194 procedure Check_Asm_Attribute;
195 -- Common semantic checks for Asm_Input and Asm_Output attributes
197 procedure Check_Component;
198 -- Common processing for Bit_Position, First_Bit, Last_Bit, and
199 -- Position. Checks prefix is an appropriate selected component.
201 procedure Check_Decimal_Fixed_Point_Type;
202 -- Check that prefix of attribute N is a decimal fixed-point type
204 procedure Check_Dereference;
205 -- If the prefix of attribute is an object of an access type, then
206 -- introduce an explicit deference, and adjust P_Type accordingly.
208 procedure Check_Discrete_Type;
209 -- Verify that prefix of attribute N is a discrete type
212 -- Check that no attribute arguments are present
214 procedure Check_Either_E0_Or_E1;
215 -- Check that there are zero or one attribute arguments present
218 -- Check that exactly one attribute argument is present
221 -- Check that two attribute arguments are present
223 procedure Check_Enum_Image;
224 -- If the prefix type is an enumeration type, set all its literals
225 -- as referenced, since the image function could possibly end up
226 -- referencing any of the literals indirectly.
228 procedure Check_Fixed_Point_Type;
229 -- Verify that prefix of attribute N is a fixed type
231 procedure Check_Fixed_Point_Type_0;
232 -- Verify that prefix of attribute N is a fixed type and that
233 -- no attribute expressions are present
235 procedure Check_Floating_Point_Type;
236 -- Verify that prefix of attribute N is a float type
238 procedure Check_Floating_Point_Type_0;
239 -- Verify that prefix of attribute N is a float type and that
240 -- no attribute expressions are present
242 procedure Check_Floating_Point_Type_1;
243 -- Verify that prefix of attribute N is a float type and that
244 -- exactly one attribute expression is present
246 procedure Check_Floating_Point_Type_2;
247 -- Verify that prefix of attribute N is a float type and that
248 -- two attribute expressions are present
250 procedure Legal_Formal_Attribute;
251 -- Common processing for attributes Definite, Has_Access_Values,
252 -- 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_Modular_Integer_Type;
261 -- Verify that prefix of attribute N is a modular integer type
263 procedure Check_Not_Incomplete_Type;
264 -- Check that P (the prefix of the attribute) is not an incomplete
265 -- type or a private type for which no full view has been given.
267 procedure Check_Object_Reference (P : Node_Id);
268 -- Check that P (the prefix of the attribute) is an object reference
270 procedure Check_Program_Unit;
271 -- Verify that prefix of attribute N is a program unit
273 procedure Check_Real_Type;
274 -- Verify that prefix of attribute N is fixed or float type
276 procedure Check_Scalar_Type;
277 -- Verify that prefix of attribute N is a scalar type
279 procedure Check_Standard_Prefix;
280 -- Verify that prefix of attribute N is package Standard
282 procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
283 -- Validity checking for stream attribute. Nam is the TSS name of the
284 -- corresponding possible defined attribute function (e.g. for the
285 -- Read attribute, Nam will be TSS_Stream_Read).
287 procedure Check_Task_Prefix;
288 -- Verify that prefix of attribute N is a task or task type
290 procedure Check_Type;
291 -- Verify that the prefix of attribute N is a type
293 procedure Check_Unit_Name (Nod : Node_Id);
294 -- Check that Nod is of the form of a library unit name, i.e that
295 -- it is an identifier, or a selected component whose prefix is
296 -- itself of the form of a library unit name. Note that this is
297 -- quite different from Check_Program_Unit, since it only checks
298 -- the syntactic form of the name, not the semantic identity. This
299 -- is because it is used with attributes (Elab_Body, Elab_Spec, and
300 -- UET_Address) which can refer to non-visible unit.
302 procedure Error_Attr (Msg : String; Error_Node : Node_Id);
303 pragma No_Return (Error_Attr);
304 procedure Error_Attr;
305 pragma No_Return (Error_Attr);
306 -- Posts error using Error_Msg_N at given node, sets type of attribute
307 -- node to Any_Type, and then raises Bad_Attribute to avoid any further
308 -- semantic processing. The message typically contains a % insertion
309 -- character which is replaced by the attribute name. The call with
310 -- no arguments is used when the caller has already generated the
311 -- required error messages.
313 procedure Standard_Attribute (Val : Int);
314 -- Used to process attributes whose prefix is package Standard which
315 -- yield values of type Universal_Integer. The attribute reference
316 -- node is rewritten with an integer literal of the given value.
318 procedure Unexpected_Argument (En : Node_Id);
319 -- Signal unexpected attribute argument (En is the argument)
321 procedure Validate_Non_Static_Attribute_Function_Call;
322 -- Called when processing an attribute that is a function call to a
323 -- non-static function, i.e. an attribute function that either takes
324 -- non-scalar arguments or returns a non-scalar result. Verifies that
325 -- such a call does not appear in a preelaborable context.
327 ------------------------------
328 -- Analyze_Access_Attribute --
329 ------------------------------
331 procedure Analyze_Access_Attribute is
332 Acc_Type : Entity_Id;
337 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
338 -- Build an access-to-object type whose designated type is DT,
339 -- and whose Ekind is appropriate to the attribute type. The
340 -- type that is constructed is returned as the result.
342 procedure Build_Access_Subprogram_Type (P : Node_Id);
343 -- Build an access to subprogram whose designated type is
344 -- the type of the prefix. If prefix is overloaded, so it the
345 -- node itself. The result is stored in Acc_Type.
347 ------------------------------
348 -- Build_Access_Object_Type --
349 ------------------------------
351 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
355 if Aname = Name_Unrestricted_Access then
358 (E_Allocator_Type, Current_Scope, Loc, 'A');
362 (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
365 Set_Etype (Typ, Typ);
366 Init_Size_Align (Typ);
368 Set_Associated_Node_For_Itype (Typ, N);
369 Set_Directly_Designated_Type (Typ, DT);
371 end Build_Access_Object_Type;
373 ----------------------------------
374 -- Build_Access_Subprogram_Type --
375 ----------------------------------
377 procedure Build_Access_Subprogram_Type (P : Node_Id) is
378 Index : Interp_Index;
381 function Get_Kind (E : Entity_Id) return Entity_Kind;
382 -- Distinguish between access to regular/protected subprograms
388 function Get_Kind (E : Entity_Id) return Entity_Kind is
390 if Convention (E) = Convention_Protected then
391 return E_Access_Protected_Subprogram_Type;
393 return E_Access_Subprogram_Type;
397 -- Start of processing for Build_Access_Subprogram_Type
400 -- In the case of an access to subprogram, use the name of the
401 -- subprogram itself as the designated type. Type-checking in
402 -- this case compares the signatures of the designated types.
404 Set_Etype (N, Any_Type);
406 if not Is_Overloaded (P) then
407 if not Is_Intrinsic_Subprogram (Entity (P)) then
410 (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
411 Set_Etype (Acc_Type, Acc_Type);
412 Set_Directly_Designated_Type (Acc_Type, Entity (P));
413 Set_Etype (N, Acc_Type);
417 Get_First_Interp (P, Index, It);
418 while Present (It.Nam) loop
419 if not Is_Intrinsic_Subprogram (It.Nam) then
422 (Get_Kind (It.Nam), Current_Scope, Loc, 'A');
423 Set_Etype (Acc_Type, Acc_Type);
424 Set_Directly_Designated_Type (Acc_Type, It.Nam);
425 Add_One_Interp (N, Acc_Type, Acc_Type);
428 Get_Next_Interp (Index, It);
432 if Etype (N) = Any_Type then
433 Error_Attr ("prefix of % attribute cannot be intrinsic", P);
435 end Build_Access_Subprogram_Type;
437 -- Start of processing for Analyze_Access_Attribute
442 if Nkind (P) = N_Character_Literal then
444 ("prefix of % attribute cannot be enumeration literal", P);
447 -- Case of access to subprogram
449 if Is_Entity_Name (P)
450 and then Is_Overloadable (Entity (P))
452 -- Not allowed for nested subprograms if No_Implicit_Dynamic_Code
453 -- restriction set (since in general a trampoline is required).
455 if not Is_Library_Level_Entity (Entity (P)) then
456 Check_Restriction (No_Implicit_Dynamic_Code, P);
459 if Is_Always_Inlined (Entity (P)) then
461 ("prefix of % attribute cannot be Inline_Always subprogram",
465 -- Build the appropriate subprogram type
467 Build_Access_Subprogram_Type (P);
469 -- For unrestricted access, kill current values, since this
470 -- attribute allows a reference to a local subprogram that
471 -- could modify local variables to be passed out of scope
473 if Aname = Name_Unrestricted_Access then
479 -- Component is an operation of a protected type
481 elsif Nkind (P) = N_Selected_Component
482 and then Is_Overloadable (Entity (Selector_Name (P)))
484 if Ekind (Entity (Selector_Name (P))) = E_Entry then
485 Error_Attr ("prefix of % attribute must be subprogram", P);
488 Build_Access_Subprogram_Type (Selector_Name (P));
492 -- Deal with incorrect reference to a type, but note that some
493 -- accesses are allowed (references to the current type instance).
495 if Is_Entity_Name (P) then
496 Scop := Current_Scope;
499 if Is_Type (Typ) then
501 -- OK if we are within the scope of a limited type
502 -- let's mark the component as having per object constraint
504 if Is_Anonymous_Tagged_Base (Scop, Typ) then
512 Q : Node_Id := Parent (N);
516 and then Nkind (Q) /= N_Component_Declaration
521 Set_Has_Per_Object_Constraint (
522 Defining_Identifier (Q), True);
526 if Nkind (P) = N_Expanded_Name then
528 ("current instance prefix must be a direct name", P);
531 -- If a current instance attribute appears within a
532 -- a component constraint it must appear alone; other
533 -- contexts (default expressions, within a task body)
534 -- are not subject to this restriction.
536 if not In_Default_Expression
537 and then not Has_Completion (Scop)
539 Nkind (Parent (N)) /= N_Discriminant_Association
541 Nkind (Parent (N)) /= N_Index_Or_Discriminant_Constraint
544 ("current instance attribute must appear alone", N);
547 -- OK if we are in initialization procedure for the type
548 -- in question, in which case the reference to the type
549 -- is rewritten as a reference to the current object.
551 elsif Ekind (Scop) = E_Procedure
552 and then Is_Init_Proc (Scop)
553 and then Etype (First_Formal (Scop)) = Typ
556 Make_Attribute_Reference (Loc,
557 Prefix => Make_Identifier (Loc, Name_uInit),
558 Attribute_Name => Name_Unrestricted_Access));
562 -- OK if a task type, this test needs sharpening up ???
564 elsif Is_Task_Type (Typ) then
567 -- Otherwise we have an error case
570 Error_Attr ("% attribute cannot be applied to type", P);
576 -- If we fall through, we have a normal access to object case.
577 -- Unrestricted_Access is legal wherever an allocator would be
578 -- legal, so its Etype is set to E_Allocator. The expected type
579 -- of the other attributes is a general access type, and therefore
580 -- we label them with E_Access_Attribute_Type.
582 if not Is_Overloaded (P) then
583 Acc_Type := Build_Access_Object_Type (P_Type);
584 Set_Etype (N, Acc_Type);
587 Index : Interp_Index;
591 Set_Etype (N, Any_Type);
592 Get_First_Interp (P, Index, It);
594 while Present (It.Typ) loop
595 Acc_Type := Build_Access_Object_Type (It.Typ);
596 Add_One_Interp (N, Acc_Type, Acc_Type);
597 Get_Next_Interp (Index, It);
602 -- If we have an access to an object, and the attribute comes
603 -- from source, then set the object as potentially source modified.
604 -- We do this because the resulting access pointer can be used to
605 -- modify the variable, and we might not detect this, leading to
606 -- some junk warnings.
608 if Is_Entity_Name (P) then
609 Set_Never_Set_In_Source (Entity (P), False);
612 -- Check for aliased view unless unrestricted case. We allow
613 -- a nonaliased prefix when within an instance because the
614 -- prefix may have been a tagged formal object, which is
615 -- defined to be aliased even when the actual might not be
616 -- (other instance cases will have been caught in the generic).
617 -- Similarly, within an inlined body we know that the attribute
618 -- is legal in the original subprogram, and therefore legal in
621 if Aname /= Name_Unrestricted_Access
622 and then not Is_Aliased_View (P)
623 and then not In_Instance
624 and then not In_Inlined_Body
626 Error_Attr ("prefix of % attribute must be aliased", P);
628 end Analyze_Access_Attribute;
630 --------------------------------
631 -- Check_Array_Or_Scalar_Type --
632 --------------------------------
634 procedure Check_Array_Or_Scalar_Type is
638 -- Dimension number for array attributes
641 -- Case of string literal or string literal subtype. These cases
642 -- cannot arise from legal Ada code, but the expander is allowed
643 -- to generate them. They require special handling because string
644 -- literal subtypes do not have standard bounds (the whole idea
645 -- of these subtypes is to avoid having to generate the bounds)
647 if Ekind (P_Type) = E_String_Literal_Subtype then
648 Set_Etype (N, Etype (First_Index (P_Base_Type)));
653 elsif Is_Scalar_Type (P_Type) then
657 Error_Attr ("invalid argument in % attribute", E1);
659 Set_Etype (N, P_Base_Type);
663 -- The following is a special test to allow 'First to apply to
664 -- private scalar types if the attribute comes from generated
665 -- code. This occurs in the case of Normalize_Scalars code.
667 elsif Is_Private_Type (P_Type)
668 and then Present (Full_View (P_Type))
669 and then Is_Scalar_Type (Full_View (P_Type))
670 and then not Comes_From_Source (N)
672 Set_Etype (N, Implementation_Base_Type (P_Type));
674 -- Array types other than string literal subtypes handled above
679 -- We know prefix is an array type, or the name of an array
680 -- object, and that the expression, if present, is static
681 -- and within the range of the dimensions of the type.
683 pragma Assert (Is_Array_Type (P_Type));
684 Index := First_Index (P_Base_Type);
688 -- First dimension assumed
690 Set_Etype (N, Base_Type (Etype (Index)));
693 D := UI_To_Int (Intval (E1));
695 for J in 1 .. D - 1 loop
699 Set_Etype (N, Base_Type (Etype (Index)));
700 Set_Etype (E1, Standard_Integer);
703 end Check_Array_Or_Scalar_Type;
705 ----------------------
706 -- Check_Array_Type --
707 ----------------------
709 procedure Check_Array_Type is
711 -- Dimension number for array attributes
714 -- If the type is a string literal type, then this must be generated
715 -- internally, and no further check is required on its legality.
717 if Ekind (P_Type) = E_String_Literal_Subtype then
720 -- If the type is a composite, it is an illegal aggregate, no point
723 elsif P_Type = Any_Composite then
727 -- Normal case of array type or subtype
729 Check_Either_E0_Or_E1;
732 if Is_Array_Type (P_Type) then
733 if not Is_Constrained (P_Type)
734 and then Is_Entity_Name (P)
735 and then Is_Type (Entity (P))
737 -- Note: we do not call Error_Attr here, since we prefer to
738 -- continue, using the relevant index type of the array,
739 -- even though it is unconstrained. This gives better error
740 -- recovery behavior.
742 Error_Msg_Name_1 := Aname;
744 ("prefix for % attribute must be constrained array", P);
747 D := Number_Dimensions (P_Type);
750 if Is_Private_Type (P_Type) then
752 ("prefix for % attribute may not be private type", P);
754 elsif Is_Access_Type (P_Type)
755 and then Is_Array_Type (Designated_Type (P_Type))
756 and then Is_Entity_Name (P)
757 and then Is_Type (Entity (P))
759 Error_Attr ("prefix of % attribute cannot be access type", P);
761 elsif Attr_Id = Attribute_First
763 Attr_Id = Attribute_Last
765 Error_Attr ("invalid prefix for % attribute", P);
768 Error_Attr ("prefix for % attribute must be array", P);
773 Resolve (E1, Any_Integer);
774 Set_Etype (E1, Standard_Integer);
776 if not Is_Static_Expression (E1)
777 or else Raises_Constraint_Error (E1)
780 ("expression for dimension must be static!", E1);
783 elsif UI_To_Int (Expr_Value (E1)) > D
784 or else UI_To_Int (Expr_Value (E1)) < 1
786 Error_Attr ("invalid dimension number for array type", E1);
789 end Check_Array_Type;
791 -------------------------
792 -- Check_Asm_Attribute --
793 -------------------------
795 procedure Check_Asm_Attribute is
800 -- Check first argument is static string expression
802 Analyze_And_Resolve (E1, Standard_String);
804 if Etype (E1) = Any_Type then
807 elsif not Is_OK_Static_Expression (E1) then
809 ("constraint argument must be static string expression!", E1);
813 -- Check second argument is right type
815 Analyze_And_Resolve (E2, Entity (P));
817 -- Note: that is all we need to do, we don't need to check
818 -- that it appears in a correct context. The Ada type system
819 -- will do that for us.
821 end Check_Asm_Attribute;
823 ---------------------
824 -- Check_Component --
825 ---------------------
827 procedure Check_Component is
831 if Nkind (P) /= N_Selected_Component
833 (Ekind (Entity (Selector_Name (P))) /= E_Component
835 Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
838 ("prefix for % attribute must be selected component", P);
842 ------------------------------------
843 -- Check_Decimal_Fixed_Point_Type --
844 ------------------------------------
846 procedure Check_Decimal_Fixed_Point_Type is
850 if not Is_Decimal_Fixed_Point_Type (P_Type) then
852 ("prefix of % attribute must be decimal type", P);
854 end Check_Decimal_Fixed_Point_Type;
856 -----------------------
857 -- Check_Dereference --
858 -----------------------
860 procedure Check_Dereference is
863 -- Case of a subtype mark
865 if Is_Entity_Name (P)
866 and then Is_Type (Entity (P))
871 -- Case of an expression
875 if Is_Access_Type (P_Type) then
877 -- If there is an implicit dereference, then we must freeze
878 -- the designated type of the access type, since the type of
879 -- the referenced array is this type (see AI95-00106).
881 Freeze_Before (N, Designated_Type (P_Type));
884 Make_Explicit_Dereference (Sloc (P),
885 Prefix => Relocate_Node (P)));
887 Analyze_And_Resolve (P);
890 if P_Type = Any_Type then
894 P_Base_Type := Base_Type (P_Type);
896 end Check_Dereference;
898 -------------------------
899 -- Check_Discrete_Type --
900 -------------------------
902 procedure Check_Discrete_Type is
906 if not Is_Discrete_Type (P_Type) then
907 Error_Attr ("prefix of % attribute must be discrete type", P);
909 end Check_Discrete_Type;
915 procedure Check_E0 is
918 Unexpected_Argument (E1);
926 procedure Check_E1 is
928 Check_Either_E0_Or_E1;
932 -- Special-case attributes that are functions and that appear as
933 -- the prefix of another attribute. Error is posted on parent.
935 if Nkind (Parent (N)) = N_Attribute_Reference
936 and then (Attribute_Name (Parent (N)) = Name_Address
938 Attribute_Name (Parent (N)) = Name_Code_Address
940 Attribute_Name (Parent (N)) = Name_Access)
942 Error_Msg_Name_1 := Attribute_Name (Parent (N));
943 Error_Msg_N ("illegal prefix for % attribute", Parent (N));
944 Set_Etype (Parent (N), Any_Type);
945 Set_Entity (Parent (N), Any_Type);
949 Error_Attr ("missing argument for % attribute", N);
958 procedure Check_E2 is
961 Error_Attr ("missing arguments for % attribute (2 required)", N);
963 Error_Attr ("missing argument for % attribute (2 required)", N);
967 ---------------------------
968 -- Check_Either_E0_Or_E1 --
969 ---------------------------
971 procedure Check_Either_E0_Or_E1 is
974 Unexpected_Argument (E2);
976 end Check_Either_E0_Or_E1;
978 ----------------------
979 -- Check_Enum_Image --
980 ----------------------
982 procedure Check_Enum_Image is
986 if Is_Enumeration_Type (P_Base_Type) then
987 Lit := First_Literal (P_Base_Type);
988 while Present (Lit) loop
989 Set_Referenced (Lit);
993 end Check_Enum_Image;
995 ----------------------------
996 -- Check_Fixed_Point_Type --
997 ----------------------------
999 procedure Check_Fixed_Point_Type is
1003 if not Is_Fixed_Point_Type (P_Type) then
1004 Error_Attr ("prefix of % attribute must be fixed point type", P);
1006 end Check_Fixed_Point_Type;
1008 ------------------------------
1009 -- Check_Fixed_Point_Type_0 --
1010 ------------------------------
1012 procedure Check_Fixed_Point_Type_0 is
1014 Check_Fixed_Point_Type;
1016 end Check_Fixed_Point_Type_0;
1018 -------------------------------
1019 -- Check_Floating_Point_Type --
1020 -------------------------------
1022 procedure Check_Floating_Point_Type is
1026 if not Is_Floating_Point_Type (P_Type) then
1027 Error_Attr ("prefix of % attribute must be float type", P);
1029 end Check_Floating_Point_Type;
1031 ---------------------------------
1032 -- Check_Floating_Point_Type_0 --
1033 ---------------------------------
1035 procedure Check_Floating_Point_Type_0 is
1037 Check_Floating_Point_Type;
1039 end Check_Floating_Point_Type_0;
1041 ---------------------------------
1042 -- Check_Floating_Point_Type_1 --
1043 ---------------------------------
1045 procedure Check_Floating_Point_Type_1 is
1047 Check_Floating_Point_Type;
1049 end Check_Floating_Point_Type_1;
1051 ---------------------------------
1052 -- Check_Floating_Point_Type_2 --
1053 ---------------------------------
1055 procedure Check_Floating_Point_Type_2 is
1057 Check_Floating_Point_Type;
1059 end Check_Floating_Point_Type_2;
1061 ------------------------
1062 -- Check_Integer_Type --
1063 ------------------------
1065 procedure Check_Integer_Type is
1069 if not Is_Integer_Type (P_Type) then
1070 Error_Attr ("prefix of % attribute must be integer type", P);
1072 end Check_Integer_Type;
1074 ------------------------
1075 -- Check_Library_Unit --
1076 ------------------------
1078 procedure Check_Library_Unit is
1080 if not Is_Compilation_Unit (Entity (P)) then
1081 Error_Attr ("prefix of % attribute must be library unit", P);
1083 end Check_Library_Unit;
1085 --------------------------------
1086 -- Check_Modular_Integer_Type --
1087 --------------------------------
1089 procedure Check_Modular_Integer_Type is
1093 if not Is_Modular_Integer_Type (P_Type) then
1095 ("prefix of % attribute must be modular integer type", P);
1097 end Check_Modular_Integer_Type;
1099 -------------------------------
1100 -- Check_Not_Incomplete_Type --
1101 -------------------------------
1103 procedure Check_Not_Incomplete_Type is
1105 if not Is_Entity_Name (P)
1106 or else not Is_Type (Entity (P))
1107 or else In_Default_Expression
1112 Check_Fully_Declared (P_Type, P);
1114 end Check_Not_Incomplete_Type;
1116 ----------------------------
1117 -- Check_Object_Reference --
1118 ----------------------------
1120 procedure Check_Object_Reference (P : Node_Id) is
1124 -- If we need an object, and we have a prefix that is the name of
1125 -- a function entity, convert it into a function call.
1127 if Is_Entity_Name (P)
1128 and then Ekind (Entity (P)) = E_Function
1130 Rtyp := Etype (Entity (P));
1133 Make_Function_Call (Sloc (P),
1134 Name => Relocate_Node (P)));
1136 Analyze_And_Resolve (P, Rtyp);
1138 -- Otherwise we must have an object reference
1140 elsif not Is_Object_Reference (P) then
1141 Error_Attr ("prefix of % attribute must be object", P);
1143 end Check_Object_Reference;
1145 ------------------------
1146 -- Check_Program_Unit --
1147 ------------------------
1149 procedure Check_Program_Unit is
1151 if Is_Entity_Name (P) then
1153 K : constant Entity_Kind := Ekind (Entity (P));
1154 T : constant Entity_Id := Etype (Entity (P));
1157 if K in Subprogram_Kind
1158 or else K in Task_Kind
1159 or else K in Protected_Kind
1160 or else K = E_Package
1161 or else K in Generic_Unit_Kind
1162 or else (K = E_Variable
1166 Is_Protected_Type (T)))
1173 Error_Attr ("prefix of % attribute must be program unit", P);
1174 end Check_Program_Unit;
1176 ---------------------
1177 -- Check_Real_Type --
1178 ---------------------
1180 procedure Check_Real_Type is
1184 if not Is_Real_Type (P_Type) then
1185 Error_Attr ("prefix of % attribute must be real type", P);
1187 end Check_Real_Type;
1189 -----------------------
1190 -- Check_Scalar_Type --
1191 -----------------------
1193 procedure Check_Scalar_Type is
1197 if not Is_Scalar_Type (P_Type) then
1198 Error_Attr ("prefix of % attribute must be scalar type", P);
1200 end Check_Scalar_Type;
1202 ---------------------------
1203 -- Check_Standard_Prefix --
1204 ---------------------------
1206 procedure Check_Standard_Prefix is
1210 if Nkind (P) /= N_Identifier
1211 or else Chars (P) /= Name_Standard
1213 Error_Attr ("only allowed prefix for % attribute is Standard", P);
1216 end Check_Standard_Prefix;
1218 ----------------------------
1219 -- Check_Stream_Attribute --
1220 ----------------------------
1222 procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
1226 Validate_Non_Static_Attribute_Function_Call;
1228 -- With the exception of 'Input, Stream attributes are procedures,
1229 -- and can only appear at the position of procedure calls. We check
1230 -- for this here, before they are rewritten, to give a more precise
1233 if Nam = TSS_Stream_Input then
1236 elsif Is_List_Member (N)
1237 and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
1238 and then Nkind (Parent (N)) /= N_Aggregate
1244 ("invalid context for attribute%, which is a procedure", N);
1248 Btyp := Implementation_Base_Type (P_Type);
1250 -- Stream attributes not allowed on limited types unless the
1251 -- attribute reference was generated by the expander (in which
1252 -- case the underlying type will be used, as described in Sinfo),
1253 -- or the attribute was specified explicitly for the type itself
1254 -- or one of its ancestors (taking visibility rules into account if
1255 -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
1256 -- (with no visibility restriction).
1258 if Comes_From_Source (N)
1259 and then not Stream_Attribute_Available (P_Type, Nam)
1260 and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
1262 Error_Msg_Name_1 := Aname;
1264 if Is_Limited_Type (P_Type) then
1266 ("limited type& has no% attribute", P, P_Type);
1267 Explain_Limited_Type (P_Type, P);
1270 ("attribute% for type& is not available", P, P_Type);
1274 -- Check for violation of restriction No_Stream_Attributes
1276 if Is_RTE (P_Type, RE_Exception_Id)
1278 Is_RTE (P_Type, RE_Exception_Occurrence)
1280 Check_Restriction (No_Exception_Registration, P);
1283 -- Here we must check that the first argument is an access type
1284 -- that is compatible with Ada.Streams.Root_Stream_Type'Class.
1286 Analyze_And_Resolve (E1);
1289 -- Note: the double call to Root_Type here is needed because the
1290 -- root type of a class-wide type is the corresponding type (e.g.
1291 -- X for X'Class, and we really want to go to the root.
1293 if not Is_Access_Type (Etyp)
1294 or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
1295 RTE (RE_Root_Stream_Type)
1298 ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
1301 -- Check that the second argument is of the right type if there is
1302 -- one (the Input attribute has only one argument so this is skipped)
1304 if Present (E2) then
1307 if Nam = TSS_Stream_Read
1308 and then not Is_OK_Variable_For_Out_Formal (E2)
1311 ("second argument of % attribute must be a variable", E2);
1314 Resolve (E2, P_Type);
1316 end Check_Stream_Attribute;
1318 -----------------------
1319 -- Check_Task_Prefix --
1320 -----------------------
1322 procedure Check_Task_Prefix is
1326 if Is_Task_Type (Etype (P))
1327 or else (Is_Access_Type (Etype (P))
1328 and then Is_Task_Type (Designated_Type (Etype (P))))
1332 Error_Attr ("prefix of % attribute must be a task", P);
1334 end Check_Task_Prefix;
1340 -- The possibilities are an entity name denoting a type, or an
1341 -- attribute reference that denotes a type (Base or Class). If
1342 -- the type is incomplete, replace it with its full view.
1344 procedure Check_Type is
1346 if not Is_Entity_Name (P)
1347 or else not Is_Type (Entity (P))
1349 Error_Attr ("prefix of % attribute must be a type", P);
1351 elsif Ekind (Entity (P)) = E_Incomplete_Type
1352 and then Present (Full_View (Entity (P)))
1354 P_Type := Full_View (Entity (P));
1355 Set_Entity (P, P_Type);
1359 ---------------------
1360 -- Check_Unit_Name --
1361 ---------------------
1363 procedure Check_Unit_Name (Nod : Node_Id) is
1365 if Nkind (Nod) = N_Identifier then
1368 elsif Nkind (Nod) = N_Selected_Component then
1369 Check_Unit_Name (Prefix (Nod));
1371 if Nkind (Selector_Name (Nod)) = N_Identifier then
1376 Error_Attr ("argument for % attribute must be unit name", P);
1377 end Check_Unit_Name;
1383 procedure Error_Attr is
1385 Set_Etype (N, Any_Type);
1386 Set_Entity (N, Any_Type);
1387 raise Bad_Attribute;
1390 procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
1392 Error_Msg_Name_1 := Aname;
1393 Error_Msg_N (Msg, Error_Node);
1397 ----------------------------
1398 -- Legal_Formal_Attribute --
1399 ----------------------------
1401 procedure Legal_Formal_Attribute is
1405 if not Is_Entity_Name (P)
1406 or else not Is_Type (Entity (P))
1408 Error_Attr ("prefix of % attribute must be generic type", N);
1410 elsif Is_Generic_Actual_Type (Entity (P))
1412 or else In_Inlined_Body
1416 elsif Is_Generic_Type (Entity (P)) then
1417 if not Is_Indefinite_Subtype (Entity (P)) then
1419 ("prefix of % attribute must be indefinite generic type", N);
1424 ("prefix of % attribute must be indefinite generic type", N);
1427 Set_Etype (N, Standard_Boolean);
1428 end Legal_Formal_Attribute;
1430 ------------------------
1431 -- Standard_Attribute --
1432 ------------------------
1434 procedure Standard_Attribute (Val : Int) is
1436 Check_Standard_Prefix;
1438 -- First a special check (more like a kludge really). For GNAT5
1439 -- on Windows, the alignments in GCC are severely mixed up. In
1440 -- particular, we have a situation where the maximum alignment
1441 -- that GCC thinks is possible is greater than the guaranteed
1442 -- alignment at run-time. That causes many problems. As a partial
1443 -- cure for this situation, we force a value of 4 for the maximum
1444 -- alignment attribute on this target. This still does not solve
1445 -- all problems, but it helps.
1447 -- A further (even more horrible) dimension to this kludge is now
1448 -- installed. There are two uses for Maximum_Alignment, one is to
1449 -- determine the maximum guaranteed alignment, that's the one we
1450 -- want the kludge to yield as 4. The other use is to maximally
1451 -- align objects, we can't use 4 here, since for example, long
1452 -- long integer has an alignment of 8, so we will get errors.
1454 -- It is of course impossible to determine which use the programmer
1455 -- has in mind, but an approximation for now is to disconnect the
1456 -- kludge if the attribute appears in an alignment clause.
1458 -- To be removed if GCC ever gets its act together here ???
1460 Alignment_Kludge : declare
1463 function On_X86 return Boolean;
1464 -- Determine if target is x86 (ia32), return True if so
1470 function On_X86 return Boolean is
1471 T : constant String := Sdefault.Target_Name.all;
1474 -- There is no clean way to check this. That's not surprising,
1475 -- the front end should not be doing this kind of test ???. The
1476 -- way we do it is test for either "86" or "pentium" being in
1477 -- the string for the target name. However, we need to exclude
1478 -- x86_64 for this check.
1480 for J in T'First .. T'Last - 1 loop
1481 if (T (J .. J + 1) = "86"
1484 or else T (J + 2 .. J + 4) /= "_64"))
1485 or else (J <= T'Last - 6
1486 and then T (J .. J + 6) = "pentium")
1496 if Aname = Name_Maximum_Alignment and then On_X86 then
1499 while Nkind (P) in N_Subexpr loop
1503 if Nkind (P) /= N_Attribute_Definition_Clause
1504 or else Chars (P) /= Name_Alignment
1506 Rewrite (N, Make_Integer_Literal (Loc, 4));
1511 end Alignment_Kludge;
1513 -- Normally we get the value from gcc ???
1515 Rewrite (N, Make_Integer_Literal (Loc, Val));
1517 end Standard_Attribute;
1519 -------------------------
1520 -- Unexpected Argument --
1521 -------------------------
1523 procedure Unexpected_Argument (En : Node_Id) is
1525 Error_Attr ("unexpected argument for % attribute", En);
1526 end Unexpected_Argument;
1528 -------------------------------------------------
1529 -- Validate_Non_Static_Attribute_Function_Call --
1530 -------------------------------------------------
1532 -- This function should be moved to Sem_Dist ???
1534 procedure Validate_Non_Static_Attribute_Function_Call is
1536 if In_Preelaborated_Unit
1537 and then not In_Subprogram_Or_Concurrent_Unit
1539 Flag_Non_Static_Expr
1540 ("non-static function call in preelaborated unit!", N);
1542 end Validate_Non_Static_Attribute_Function_Call;
1544 -----------------------------------------------
1545 -- Start of Processing for Analyze_Attribute --
1546 -----------------------------------------------
1549 -- Immediate return if unrecognized attribute (already diagnosed
1550 -- by parser, so there is nothing more that we need to do)
1552 if not Is_Attribute_Name (Aname) then
1553 raise Bad_Attribute;
1556 -- Deal with Ada 83 and Features issues
1558 if Comes_From_Source (N) then
1559 if not Attribute_83 (Attr_Id) then
1560 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1561 Error_Msg_Name_1 := Aname;
1562 Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
1565 if Attribute_Impl_Def (Attr_Id) then
1566 Check_Restriction (No_Implementation_Attributes, N);
1571 -- Remote access to subprogram type access attribute reference needs
1572 -- unanalyzed copy for tree transformation. The analyzed copy is used
1573 -- for its semantic information (whether prefix is a remote subprogram
1574 -- name), the unanalyzed copy is used to construct new subtree rooted
1575 -- with N_Aggregate which represents a fat pointer aggregate.
1577 if Aname = Name_Access then
1578 Discard_Node (Copy_Separate_Tree (N));
1581 -- Analyze prefix and exit if error in analysis. If the prefix is an
1582 -- incomplete type, use full view if available. A special case is
1583 -- that we never analyze the prefix of an Elab_Body or Elab_Spec
1584 -- or UET_Address attribute.
1586 if Aname /= Name_Elab_Body
1588 Aname /= Name_Elab_Spec
1590 Aname /= Name_UET_Address
1593 P_Type := Etype (P);
1595 if Is_Entity_Name (P)
1596 and then Present (Entity (P))
1597 and then Is_Type (Entity (P))
1598 and then Ekind (Entity (P)) = E_Incomplete_Type
1600 P_Type := Get_Full_View (P_Type);
1601 Set_Entity (P, P_Type);
1602 Set_Etype (P, P_Type);
1605 if P_Type = Any_Type then
1606 raise Bad_Attribute;
1609 P_Base_Type := Base_Type (P_Type);
1612 -- Analyze expressions that may be present, exiting if an error occurs
1619 E1 := First (Exprs);
1622 -- Check for missing or bad expression (result of previous error)
1624 if No (E1) or else Etype (E1) = Any_Type then
1625 raise Bad_Attribute;
1630 if Present (E2) then
1633 if Etype (E2) = Any_Type then
1634 raise Bad_Attribute;
1637 if Present (Next (E2)) then
1638 Unexpected_Argument (Next (E2));
1643 -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current
1644 -- output compiling in Ada 95 mode
1646 if Ada_Version < Ada_05
1647 and then Is_Overloaded (P)
1648 and then Aname /= Name_Access
1649 and then Aname /= Name_Address
1650 and then Aname /= Name_Code_Address
1651 and then Aname /= Name_Count
1652 and then Aname /= Name_Unchecked_Access
1654 Error_Attr ("ambiguous prefix for % attribute", P);
1656 elsif Ada_Version >= Ada_05
1657 and then Is_Overloaded (P)
1658 and then Aname /= Name_Access
1659 and then Aname /= Name_Address
1660 and then Aname /= Name_Code_Address
1661 and then Aname /= Name_Unchecked_Access
1663 -- Ada 2005 (AI-345): Since protected and task types have primitive
1664 -- entry wrappers, the attributes Count, Caller and AST_Entry require
1667 if Ada_Version >= Ada_05
1668 and then (Aname = Name_Count
1669 or else Aname = Name_Caller
1670 or else Aname = Name_AST_Entry)
1673 Count : Natural := 0;
1678 Get_First_Interp (P, I, It);
1680 while Present (It.Nam) loop
1681 if Comes_From_Source (It.Nam) then
1687 Get_Next_Interp (I, It);
1691 Error_Attr ("ambiguous prefix for % attribute", P);
1693 Set_Is_Overloaded (P, False);
1698 Error_Attr ("ambiguous prefix for % attribute", P);
1702 -- Remaining processing depends on attribute
1710 when Attribute_Abort_Signal =>
1711 Check_Standard_Prefix;
1713 New_Reference_To (Stand.Abort_Signal, Loc));
1720 when Attribute_Access =>
1721 Analyze_Access_Attribute;
1727 when Attribute_Address =>
1730 -- Check for some junk cases, where we have to allow the address
1731 -- attribute but it does not make much sense, so at least for now
1732 -- just replace with Null_Address.
1734 -- We also do this if the prefix is a reference to the AST_Entry
1735 -- attribute. If expansion is active, the attribute will be
1736 -- replaced by a function call, and address will work fine and
1737 -- get the proper value, but if expansion is not active, then
1738 -- the check here allows proper semantic analysis of the reference.
1740 -- An Address attribute created by expansion is legal even when it
1741 -- applies to other entity-denoting expressions.
1743 if Is_Entity_Name (P) then
1745 Ent : constant Entity_Id := Entity (P);
1748 if Is_Subprogram (Ent) then
1749 if not Is_Library_Level_Entity (Ent) then
1750 Check_Restriction (No_Implicit_Dynamic_Code, P);
1753 Set_Address_Taken (Ent);
1755 -- An Address attribute is accepted when generated by
1756 -- the compiler for dispatching operation, and an error
1757 -- is issued once the subprogram is frozen (to avoid
1758 -- confusing errors about implicit uses of Address in
1759 -- the dispatch table initialization).
1761 if Is_Always_Inlined (Entity (P))
1762 and then Comes_From_Source (P)
1765 ("prefix of % attribute cannot be Inline_Always" &
1769 elsif Is_Object (Ent)
1770 or else Ekind (Ent) = E_Label
1772 Set_Address_Taken (Ent);
1774 -- If we have an address of an object, and the attribute
1775 -- comes from source, then set the object as potentially
1776 -- source modified. We do this because the resulting address
1777 -- can potentially be used to modify the variable and we
1778 -- might not detect this, leading to some junk warnings.
1780 Set_Never_Set_In_Source (Ent, False);
1782 elsif (Is_Concurrent_Type (Etype (Ent))
1783 and then Etype (Ent) = Base_Type (Ent))
1784 or else Ekind (Ent) = E_Package
1785 or else Is_Generic_Unit (Ent)
1788 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
1791 Error_Attr ("invalid prefix for % attribute", P);
1795 elsif Nkind (P) = N_Attribute_Reference
1796 and then Attribute_Name (P) = Name_AST_Entry
1799 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
1801 elsif Is_Object_Reference (P) then
1804 elsif Nkind (P) = N_Selected_Component
1805 and then Is_Subprogram (Entity (Selector_Name (P)))
1809 -- What exactly are we allowing here ??? and is this properly
1810 -- documented in the sinfo documentation for this node ???
1812 elsif not Comes_From_Source (N) then
1816 Error_Attr ("invalid prefix for % attribute", P);
1819 Set_Etype (N, RTE (RE_Address));
1825 when Attribute_Address_Size =>
1826 Standard_Attribute (System_Address_Size);
1832 when Attribute_Adjacent =>
1833 Check_Floating_Point_Type_2;
1834 Set_Etype (N, P_Base_Type);
1835 Resolve (E1, P_Base_Type);
1836 Resolve (E2, P_Base_Type);
1842 when Attribute_Aft =>
1843 Check_Fixed_Point_Type_0;
1844 Set_Etype (N, Universal_Integer);
1850 when Attribute_Alignment =>
1852 -- Don't we need more checking here, cf Size ???
1855 Check_Not_Incomplete_Type;
1856 Set_Etype (N, Universal_Integer);
1862 when Attribute_Asm_Input =>
1863 Check_Asm_Attribute;
1864 Set_Etype (N, RTE (RE_Asm_Input_Operand));
1870 when Attribute_Asm_Output =>
1871 Check_Asm_Attribute;
1873 if Etype (E2) = Any_Type then
1876 elsif Aname = Name_Asm_Output then
1877 if not Is_Variable (E2) then
1879 ("second argument for Asm_Output is not variable", E2);
1883 Note_Possible_Modification (E2);
1884 Set_Etype (N, RTE (RE_Asm_Output_Operand));
1890 when Attribute_AST_Entry => AST_Entry : declare
1896 -- Indicates if entry family index is present. Note the coding
1897 -- here handles the entry family case, but in fact it cannot be
1898 -- executed currently, because pragma AST_Entry does not permit
1899 -- the specification of an entry family.
1901 procedure Bad_AST_Entry;
1902 -- Signal a bad AST_Entry pragma
1904 function OK_Entry (E : Entity_Id) return Boolean;
1905 -- Checks that E is of an appropriate entity kind for an entry
1906 -- (i.e. E_Entry if Index is False, or E_Entry_Family if Index
1907 -- is set True for the entry family case). In the True case,
1908 -- makes sure that Is_AST_Entry is set on the entry.
1910 procedure Bad_AST_Entry is
1912 Error_Attr ("prefix for % attribute must be task entry", P);
1915 function OK_Entry (E : Entity_Id) return Boolean is
1920 Result := (Ekind (E) = E_Entry_Family);
1922 Result := (Ekind (E) = E_Entry);
1926 if not Is_AST_Entry (E) then
1927 Error_Msg_Name_2 := Aname;
1929 ("% attribute requires previous % pragma", P);
1936 -- Start of processing for AST_Entry
1942 -- Deal with entry family case
1944 if Nkind (P) = N_Indexed_Component then
1952 Ptyp := Etype (Pref);
1954 if Ptyp = Any_Type or else Error_Posted (Pref) then
1958 -- If the prefix is a selected component whose prefix is of an
1959 -- access type, then introduce an explicit dereference.
1960 -- ??? Could we reuse Check_Dereference here?
1962 if Nkind (Pref) = N_Selected_Component
1963 and then Is_Access_Type (Ptyp)
1966 Make_Explicit_Dereference (Sloc (Pref),
1967 Relocate_Node (Pref)));
1968 Analyze_And_Resolve (Pref, Designated_Type (Ptyp));
1971 -- Prefix can be of the form a.b, where a is a task object
1972 -- and b is one of the entries of the corresponding task type.
1974 if Nkind (Pref) = N_Selected_Component
1975 and then OK_Entry (Entity (Selector_Name (Pref)))
1976 and then Is_Object_Reference (Prefix (Pref))
1977 and then Is_Task_Type (Etype (Prefix (Pref)))
1981 -- Otherwise the prefix must be an entry of a containing task,
1982 -- or of a variable of the enclosing task type.
1985 if Nkind (Pref) = N_Identifier
1986 or else Nkind (Pref) = N_Expanded_Name
1988 Ent := Entity (Pref);
1990 if not OK_Entry (Ent)
1991 or else not In_Open_Scopes (Scope (Ent))
2001 Set_Etype (N, RTE (RE_AST_Handler));
2008 -- Note: when the base attribute appears in the context of a subtype
2009 -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
2010 -- the following circuit.
2012 when Attribute_Base => Base : declare
2016 Check_Either_E0_Or_E1;
2020 if Ada_Version >= Ada_95
2021 and then not Is_Scalar_Type (Typ)
2022 and then not Is_Generic_Type (Typ)
2024 Error_Msg_N ("prefix of Base attribute must be scalar type", N);
2026 elsif Sloc (Typ) = Standard_Location
2027 and then Base_Type (Typ) = Typ
2028 and then Warn_On_Redundant_Constructs
2031 ("?redudant attribute, & is its own base type", N, Typ);
2034 Set_Etype (N, Base_Type (Entity (P)));
2036 -- If we have an expression present, then really this is a conversion
2037 -- and the tree must be reformed. Note that this is one of the cases
2038 -- in which we do a replace rather than a rewrite, because the
2039 -- original tree is junk.
2041 if Present (E1) then
2043 Make_Type_Conversion (Loc,
2045 Make_Attribute_Reference (Loc,
2046 Prefix => Prefix (N),
2047 Attribute_Name => Name_Base),
2048 Expression => Relocate_Node (E1)));
2050 -- E1 may be overloaded, and its interpretations preserved
2052 Save_Interps (E1, Expression (N));
2055 -- For other cases, set the proper type as the entity of the
2056 -- attribute reference, and then rewrite the node to be an
2057 -- occurrence of the referenced base type. This way, no one
2058 -- else in the compiler has to worry about the base attribute.
2061 Set_Entity (N, Base_Type (Entity (P)));
2063 New_Reference_To (Entity (N), Loc));
2072 when Attribute_Bit => Bit :
2076 if not Is_Object_Reference (P) then
2077 Error_Attr ("prefix for % attribute must be object", P);
2079 -- What about the access object cases ???
2085 Set_Etype (N, Universal_Integer);
2092 when Attribute_Bit_Order => Bit_Order :
2097 if not Is_Record_Type (P_Type) then
2098 Error_Attr ("prefix of % attribute must be record type", P);
2101 if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
2103 New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
2106 New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
2109 Set_Etype (N, RTE (RE_Bit_Order));
2112 -- Reset incorrect indication of staticness
2114 Set_Is_Static_Expression (N, False);
2121 -- Note: in generated code, we can have a Bit_Position attribute
2122 -- applied to a (naked) record component (i.e. the prefix is an
2123 -- identifier that references an E_Component or E_Discriminant
2124 -- entity directly, and this is interpreted as expected by Gigi.
2125 -- The following code will not tolerate such usage, but when the
2126 -- expander creates this special case, it marks it as analyzed
2127 -- immediately and sets an appropriate type.
2129 when Attribute_Bit_Position =>
2131 if Comes_From_Source (N) then
2135 Set_Etype (N, Universal_Integer);
2141 when Attribute_Body_Version =>
2144 Set_Etype (N, RTE (RE_Version_String));
2150 when Attribute_Callable =>
2152 Set_Etype (N, Standard_Boolean);
2159 when Attribute_Caller => Caller : declare
2166 if Nkind (P) = N_Identifier
2167 or else Nkind (P) = N_Expanded_Name
2171 if not Is_Entry (Ent) then
2172 Error_Attr ("invalid entry name", N);
2176 Error_Attr ("invalid entry name", N);
2180 for J in reverse 0 .. Scope_Stack.Last loop
2181 S := Scope_Stack.Table (J).Entity;
2183 if S = Scope (Ent) then
2184 Error_Attr ("Caller must appear in matching accept or body", N);
2190 Set_Etype (N, RTE (RO_AT_Task_Id));
2197 when Attribute_Ceiling =>
2198 Check_Floating_Point_Type_1;
2199 Set_Etype (N, P_Base_Type);
2200 Resolve (E1, P_Base_Type);
2206 when Attribute_Class => Class : declare
2208 Check_Restriction (No_Dispatch, N);
2209 Check_Either_E0_Or_E1;
2211 -- If we have an expression present, then really this is a conversion
2212 -- and the tree must be reformed into a proper conversion. This is a
2213 -- Replace rather than a Rewrite, because the original tree is junk.
2214 -- If expression is overloaded, propagate interpretations to new one.
2216 if Present (E1) then
2218 Make_Type_Conversion (Loc,
2220 Make_Attribute_Reference (Loc,
2221 Prefix => Prefix (N),
2222 Attribute_Name => Name_Class),
2223 Expression => Relocate_Node (E1)));
2225 Save_Interps (E1, Expression (N));
2228 -- Otherwise we just need to find the proper type
2240 when Attribute_Code_Address =>
2243 if Nkind (P) = N_Attribute_Reference
2244 and then (Attribute_Name (P) = Name_Elab_Body
2246 Attribute_Name (P) = Name_Elab_Spec)
2250 elsif not Is_Entity_Name (P)
2251 or else (Ekind (Entity (P)) /= E_Function
2253 Ekind (Entity (P)) /= E_Procedure)
2255 Error_Attr ("invalid prefix for % attribute", P);
2256 Set_Address_Taken (Entity (P));
2259 Set_Etype (N, RTE (RE_Address));
2261 --------------------
2262 -- Component_Size --
2263 --------------------
2265 when Attribute_Component_Size =>
2267 Set_Etype (N, Universal_Integer);
2269 -- Note: unlike other array attributes, unconstrained arrays are OK
2271 if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
2281 when Attribute_Compose =>
2282 Check_Floating_Point_Type_2;
2283 Set_Etype (N, P_Base_Type);
2284 Resolve (E1, P_Base_Type);
2285 Resolve (E2, Any_Integer);
2291 when Attribute_Constrained =>
2293 Set_Etype (N, Standard_Boolean);
2295 -- Case from RM J.4(2) of constrained applied to private type
2297 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
2298 Check_Restriction (No_Obsolescent_Features, N);
2300 if Warn_On_Obsolescent_Feature then
2302 ("constrained for private type is an " &
2303 "obsolescent feature ('R'M 'J.4)?", N);
2306 -- If we are within an instance, the attribute must be legal
2307 -- because it was valid in the generic unit. Ditto if this is
2308 -- an inlining of a function declared in an instance.
2311 or else In_Inlined_Body
2315 -- For sure OK if we have a real private type itself, but must
2316 -- be completed, cannot apply Constrained to incomplete type.
2318 elsif Is_Private_Type (Entity (P)) then
2320 -- Note: this is one of the Annex J features that does not
2321 -- generate a warning from -gnatwj, since in fact it seems
2322 -- very useful, and is used in the GNAT runtime.
2324 Check_Not_Incomplete_Type;
2328 -- Normal (non-obsolescent case) of application to object of
2329 -- a discriminated type.
2332 Check_Object_Reference (P);
2334 -- If N does not come from source, then we allow the
2335 -- the attribute prefix to be of a private type whose
2336 -- full type has discriminants. This occurs in cases
2337 -- involving expanded calls to stream attributes.
2339 if not Comes_From_Source (N) then
2340 P_Type := Underlying_Type (P_Type);
2343 -- Must have discriminants or be an access type designating
2344 -- a type with discriminants. If it is a classwide type is
2345 -- has unknown discriminants.
2347 if Has_Discriminants (P_Type)
2348 or else Has_Unknown_Discriminants (P_Type)
2350 (Is_Access_Type (P_Type)
2351 and then Has_Discriminants (Designated_Type (P_Type)))
2355 -- Also allow an object of a generic type if extensions allowed
2356 -- and allow this for any type at all.
2358 elsif (Is_Generic_Type (P_Type)
2359 or else Is_Generic_Actual_Type (P_Type))
2360 and then Extensions_Allowed
2366 -- Fall through if bad prefix
2369 ("prefix of % attribute must be object of discriminated type", P);
2375 when Attribute_Copy_Sign =>
2376 Check_Floating_Point_Type_2;
2377 Set_Etype (N, P_Base_Type);
2378 Resolve (E1, P_Base_Type);
2379 Resolve (E2, P_Base_Type);
2385 when Attribute_Count => Count :
2394 if Nkind (P) = N_Identifier
2395 or else Nkind (P) = N_Expanded_Name
2399 if Ekind (Ent) /= E_Entry then
2400 Error_Attr ("invalid entry name", N);
2403 elsif Nkind (P) = N_Indexed_Component then
2404 if not Is_Entity_Name (Prefix (P))
2405 or else No (Entity (Prefix (P)))
2406 or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
2408 if Nkind (Prefix (P)) = N_Selected_Component
2409 and then Present (Entity (Selector_Name (Prefix (P))))
2410 and then Ekind (Entity (Selector_Name (Prefix (P)))) =
2414 ("attribute % must apply to entry of current task", P);
2417 Error_Attr ("invalid entry family name", P);
2422 Ent := Entity (Prefix (P));
2425 elsif Nkind (P) = N_Selected_Component
2426 and then Present (Entity (Selector_Name (P)))
2427 and then Ekind (Entity (Selector_Name (P))) = E_Entry
2430 ("attribute % must apply to entry of current task", P);
2433 Error_Attr ("invalid entry name", N);
2437 for J in reverse 0 .. Scope_Stack.Last loop
2438 S := Scope_Stack.Table (J).Entity;
2440 if S = Scope (Ent) then
2441 if Nkind (P) = N_Expanded_Name then
2442 Tsk := Entity (Prefix (P));
2444 -- The prefix denotes either the task type, or else a
2445 -- single task whose task type is being analyzed.
2450 or else (not Is_Type (Tsk)
2451 and then Etype (Tsk) = S
2452 and then not (Comes_From_Source (S)))
2457 ("Attribute % must apply to entry of current task", N);
2463 elsif Ekind (Scope (Ent)) in Task_Kind
2464 and then Ekind (S) /= E_Loop
2465 and then Ekind (S) /= E_Block
2466 and then Ekind (S) /= E_Entry
2467 and then Ekind (S) /= E_Entry_Family
2469 Error_Attr ("Attribute % cannot appear in inner unit", N);
2471 elsif Ekind (Scope (Ent)) = E_Protected_Type
2472 and then not Has_Completion (Scope (Ent))
2474 Error_Attr ("attribute % can only be used inside body", N);
2478 if Is_Overloaded (P) then
2480 Index : Interp_Index;
2484 Get_First_Interp (P, Index, It);
2486 while Present (It.Nam) loop
2487 if It.Nam = Ent then
2490 -- Ada 2005 (AI-345): Do not consider primitive entry
2491 -- wrappers generated for task or protected types.
2493 elsif Ada_Version >= Ada_05
2494 and then not Comes_From_Source (It.Nam)
2499 Error_Attr ("ambiguous entry name", N);
2502 Get_Next_Interp (Index, It);
2507 Set_Etype (N, Universal_Integer);
2510 -----------------------
2511 -- Default_Bit_Order --
2512 -----------------------
2514 when Attribute_Default_Bit_Order => Default_Bit_Order :
2516 Check_Standard_Prefix;
2519 if Bytes_Big_Endian then
2521 Make_Integer_Literal (Loc, False_Value));
2524 Make_Integer_Literal (Loc, True_Value));
2527 Set_Etype (N, Universal_Integer);
2528 Set_Is_Static_Expression (N);
2529 end Default_Bit_Order;
2535 when Attribute_Definite =>
2536 Legal_Formal_Attribute;
2542 when Attribute_Delta =>
2543 Check_Fixed_Point_Type_0;
2544 Set_Etype (N, Universal_Real);
2550 when Attribute_Denorm =>
2551 Check_Floating_Point_Type_0;
2552 Set_Etype (N, Standard_Boolean);
2558 when Attribute_Digits =>
2562 if not Is_Floating_Point_Type (P_Type)
2563 and then not Is_Decimal_Fixed_Point_Type (P_Type)
2566 ("prefix of % attribute must be float or decimal type", P);
2569 Set_Etype (N, Universal_Integer);
2575 -- Also handles processing for Elab_Spec
2577 when Attribute_Elab_Body | Attribute_Elab_Spec =>
2579 Check_Unit_Name (P);
2580 Set_Etype (N, Standard_Void_Type);
2582 -- We have to manually call the expander in this case to get
2583 -- the necessary expansion (normally attributes that return
2584 -- entities are not expanded).
2592 -- Shares processing with Elab_Body
2598 when Attribute_Elaborated =>
2601 Set_Etype (N, Standard_Boolean);
2607 when Attribute_Emax =>
2608 Check_Floating_Point_Type_0;
2609 Set_Etype (N, Universal_Integer);
2615 when Attribute_Enum_Rep => Enum_Rep : declare
2617 if Present (E1) then
2619 Check_Discrete_Type;
2620 Resolve (E1, P_Base_Type);
2623 if not Is_Entity_Name (P)
2624 or else (not Is_Object (Entity (P))
2626 Ekind (Entity (P)) /= E_Enumeration_Literal)
2629 ("prefix of %attribute must be " &
2630 "discrete type/object or enum literal", P);
2634 Set_Etype (N, Universal_Integer);
2641 when Attribute_Epsilon =>
2642 Check_Floating_Point_Type_0;
2643 Set_Etype (N, Universal_Real);
2649 when Attribute_Exponent =>
2650 Check_Floating_Point_Type_1;
2651 Set_Etype (N, Universal_Integer);
2652 Resolve (E1, P_Base_Type);
2658 when Attribute_External_Tag =>
2662 Set_Etype (N, Standard_String);
2664 if not Is_Tagged_Type (P_Type) then
2665 Error_Attr ("prefix of % attribute must be tagged", P);
2672 when Attribute_First =>
2673 Check_Array_Or_Scalar_Type;
2679 when Attribute_First_Bit =>
2681 Set_Etype (N, Universal_Integer);
2687 when Attribute_Fixed_Value =>
2689 Check_Fixed_Point_Type;
2690 Resolve (E1, Any_Integer);
2691 Set_Etype (N, P_Base_Type);
2697 when Attribute_Floor =>
2698 Check_Floating_Point_Type_1;
2699 Set_Etype (N, P_Base_Type);
2700 Resolve (E1, P_Base_Type);
2706 when Attribute_Fore =>
2707 Check_Fixed_Point_Type_0;
2708 Set_Etype (N, Universal_Integer);
2714 when Attribute_Fraction =>
2715 Check_Floating_Point_Type_1;
2716 Set_Etype (N, P_Base_Type);
2717 Resolve (E1, P_Base_Type);
2719 -----------------------
2720 -- Has_Access_Values --
2721 -----------------------
2723 when Attribute_Has_Access_Values =>
2726 Set_Etype (N, Standard_Boolean);
2728 -----------------------
2729 -- Has_Discriminants --
2730 -----------------------
2732 when Attribute_Has_Discriminants =>
2733 Legal_Formal_Attribute;
2739 when Attribute_Identity =>
2743 if Etype (P) = Standard_Exception_Type then
2744 Set_Etype (N, RTE (RE_Exception_Id));
2746 elsif Is_Task_Type (Etype (P))
2747 or else (Is_Access_Type (Etype (P))
2748 and then Is_Task_Type (Designated_Type (Etype (P))))
2751 Set_Etype (N, RTE (RO_AT_Task_Id));
2754 Error_Attr ("prefix of % attribute must be a task or an "
2762 when Attribute_Image => Image :
2764 Set_Etype (N, Standard_String);
2767 if Is_Real_Type (P_Type) then
2768 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2769 Error_Msg_Name_1 := Aname;
2771 ("(Ada 83) % attribute not allowed for real types", N);
2775 if Is_Enumeration_Type (P_Type) then
2776 Check_Restriction (No_Enumeration_Maps, N);
2780 Resolve (E1, P_Base_Type);
2782 Validate_Non_Static_Attribute_Function_Call;
2789 when Attribute_Img => Img :
2791 Set_Etype (N, Standard_String);
2793 if not Is_Scalar_Type (P_Type)
2794 or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
2797 ("prefix of % attribute must be scalar object name", N);
2807 when Attribute_Input =>
2809 Check_Stream_Attribute (TSS_Stream_Input);
2810 Set_Etype (N, P_Base_Type);
2816 when Attribute_Integer_Value =>
2819 Resolve (E1, Any_Fixed);
2820 Set_Etype (N, P_Base_Type);
2826 when Attribute_Large =>
2829 Set_Etype (N, Universal_Real);
2835 when Attribute_Last =>
2836 Check_Array_Or_Scalar_Type;
2842 when Attribute_Last_Bit =>
2844 Set_Etype (N, Universal_Integer);
2850 when Attribute_Leading_Part =>
2851 Check_Floating_Point_Type_2;
2852 Set_Etype (N, P_Base_Type);
2853 Resolve (E1, P_Base_Type);
2854 Resolve (E2, Any_Integer);
2860 when Attribute_Length =>
2862 Set_Etype (N, Universal_Integer);
2868 when Attribute_Machine =>
2869 Check_Floating_Point_Type_1;
2870 Set_Etype (N, P_Base_Type);
2871 Resolve (E1, P_Base_Type);
2877 when Attribute_Machine_Emax =>
2878 Check_Floating_Point_Type_0;
2879 Set_Etype (N, Universal_Integer);
2885 when Attribute_Machine_Emin =>
2886 Check_Floating_Point_Type_0;
2887 Set_Etype (N, Universal_Integer);
2889 ----------------------
2890 -- Machine_Mantissa --
2891 ----------------------
2893 when Attribute_Machine_Mantissa =>
2894 Check_Floating_Point_Type_0;
2895 Set_Etype (N, Universal_Integer);
2897 -----------------------
2898 -- Machine_Overflows --
2899 -----------------------
2901 when Attribute_Machine_Overflows =>
2904 Set_Etype (N, Standard_Boolean);
2910 when Attribute_Machine_Radix =>
2913 Set_Etype (N, Universal_Integer);
2915 --------------------
2916 -- Machine_Rounds --
2917 --------------------
2919 when Attribute_Machine_Rounds =>
2922 Set_Etype (N, Standard_Boolean);
2928 when Attribute_Machine_Size =>
2931 Check_Not_Incomplete_Type;
2932 Set_Etype (N, Universal_Integer);
2938 when Attribute_Mantissa =>
2941 Set_Etype (N, Universal_Integer);
2947 when Attribute_Max =>
2950 Resolve (E1, P_Base_Type);
2951 Resolve (E2, P_Base_Type);
2952 Set_Etype (N, P_Base_Type);
2954 ----------------------------------
2955 -- Max_Size_In_Storage_Elements --
2956 ----------------------------------
2958 when Attribute_Max_Size_In_Storage_Elements =>
2961 Check_Not_Incomplete_Type;
2962 Set_Etype (N, Universal_Integer);
2964 -----------------------
2965 -- Maximum_Alignment --
2966 -----------------------
2968 when Attribute_Maximum_Alignment =>
2969 Standard_Attribute (Ttypes.Maximum_Alignment);
2971 --------------------
2972 -- Mechanism_Code --
2973 --------------------
2975 when Attribute_Mechanism_Code =>
2976 if not Is_Entity_Name (P)
2977 or else not Is_Subprogram (Entity (P))
2979 Error_Attr ("prefix of % attribute must be subprogram", P);
2982 Check_Either_E0_Or_E1;
2984 if Present (E1) then
2985 Resolve (E1, Any_Integer);
2986 Set_Etype (E1, Standard_Integer);
2988 if not Is_Static_Expression (E1) then
2989 Flag_Non_Static_Expr
2990 ("expression for parameter number must be static!", E1);
2993 elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
2994 or else UI_To_Int (Intval (E1)) < 0
2996 Error_Attr ("invalid parameter number for %attribute", E1);
3000 Set_Etype (N, Universal_Integer);
3006 when Attribute_Min =>
3009 Resolve (E1, P_Base_Type);
3010 Resolve (E2, P_Base_Type);
3011 Set_Etype (N, P_Base_Type);
3017 when Attribute_Mod =>
3019 -- Note: this attribute is only allowed in Ada 2005 mode, but
3020 -- we do not need to test that here, since Mod is only recognized
3021 -- as an attribute name in Ada 2005 mode during the parse.
3024 Check_Modular_Integer_Type;
3025 Resolve (E1, Any_Integer);
3026 Set_Etype (N, P_Base_Type);
3032 when Attribute_Model =>
3033 Check_Floating_Point_Type_1;
3034 Set_Etype (N, P_Base_Type);
3035 Resolve (E1, P_Base_Type);
3041 when Attribute_Model_Emin =>
3042 Check_Floating_Point_Type_0;
3043 Set_Etype (N, Universal_Integer);
3049 when Attribute_Model_Epsilon =>
3050 Check_Floating_Point_Type_0;
3051 Set_Etype (N, Universal_Real);
3053 --------------------
3054 -- Model_Mantissa --
3055 --------------------
3057 when Attribute_Model_Mantissa =>
3058 Check_Floating_Point_Type_0;
3059 Set_Etype (N, Universal_Integer);
3065 when Attribute_Model_Small =>
3066 Check_Floating_Point_Type_0;
3067 Set_Etype (N, Universal_Real);
3073 when Attribute_Modulus =>
3075 Check_Modular_Integer_Type;
3076 Set_Etype (N, Universal_Integer);
3078 --------------------
3079 -- Null_Parameter --
3080 --------------------
3082 when Attribute_Null_Parameter => Null_Parameter : declare
3083 Parnt : constant Node_Id := Parent (N);
3084 GParnt : constant Node_Id := Parent (Parnt);
3086 procedure Bad_Null_Parameter (Msg : String);
3087 -- Used if bad Null parameter attribute node is found. Issues
3088 -- given error message, and also sets the type to Any_Type to
3089 -- avoid blowups later on from dealing with a junk node.
3091 procedure Must_Be_Imported (Proc_Ent : Entity_Id);
3092 -- Called to check that Proc_Ent is imported subprogram
3094 ------------------------
3095 -- Bad_Null_Parameter --
3096 ------------------------
3098 procedure Bad_Null_Parameter (Msg : String) is
3100 Error_Msg_N (Msg, N);
3101 Set_Etype (N, Any_Type);
3102 end Bad_Null_Parameter;
3104 ----------------------
3105 -- Must_Be_Imported --
3106 ----------------------
3108 procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
3109 Pent : Entity_Id := Proc_Ent;
3112 while Present (Alias (Pent)) loop
3113 Pent := Alias (Pent);
3116 -- Ignore check if procedure not frozen yet (we will get
3117 -- another chance when the default parameter is reanalyzed)
3119 if not Is_Frozen (Pent) then
3122 elsif not Is_Imported (Pent) then
3124 ("Null_Parameter can only be used with imported subprogram");
3129 end Must_Be_Imported;
3131 -- Start of processing for Null_Parameter
3136 Set_Etype (N, P_Type);
3138 -- Case of attribute used as default expression
3140 if Nkind (Parnt) = N_Parameter_Specification then
3141 Must_Be_Imported (Defining_Entity (GParnt));
3143 -- Case of attribute used as actual for subprogram (positional)
3145 elsif (Nkind (Parnt) = N_Procedure_Call_Statement
3147 Nkind (Parnt) = N_Function_Call)
3148 and then Is_Entity_Name (Name (Parnt))
3150 Must_Be_Imported (Entity (Name (Parnt)));
3152 -- Case of attribute used as actual for subprogram (named)
3154 elsif Nkind (Parnt) = N_Parameter_Association
3155 and then (Nkind (GParnt) = N_Procedure_Call_Statement
3157 Nkind (GParnt) = N_Function_Call)
3158 and then Is_Entity_Name (Name (GParnt))
3160 Must_Be_Imported (Entity (Name (GParnt)));
3162 -- Not an allowed case
3166 ("Null_Parameter must be actual or default parameter");
3175 when Attribute_Object_Size =>
3178 Check_Not_Incomplete_Type;
3179 Set_Etype (N, Universal_Integer);
3185 when Attribute_Output =>
3187 Check_Stream_Attribute (TSS_Stream_Output);
3188 Set_Etype (N, Standard_Void_Type);
3189 Resolve (N, Standard_Void_Type);
3195 when Attribute_Partition_ID =>
3198 if P_Type /= Any_Type then
3199 if not Is_Library_Level_Entity (Entity (P)) then
3201 ("prefix of % attribute must be library-level entity", P);
3203 -- The defining entity of prefix should not be declared inside
3204 -- a Pure unit. RM E.1(8).
3205 -- The Is_Pure flag has been set during declaration.
3207 elsif Is_Entity_Name (P)
3208 and then Is_Pure (Entity (P))
3211 ("prefix of % attribute must not be declared pure", P);
3215 Set_Etype (N, Universal_Integer);
3217 -------------------------
3218 -- Passed_By_Reference --
3219 -------------------------
3221 when Attribute_Passed_By_Reference =>
3224 Set_Etype (N, Standard_Boolean);
3230 when Attribute_Pool_Address =>
3232 Set_Etype (N, RTE (RE_Address));
3238 when Attribute_Pos =>
3239 Check_Discrete_Type;
3241 Resolve (E1, P_Base_Type);
3242 Set_Etype (N, Universal_Integer);
3248 when Attribute_Position =>
3250 Set_Etype (N, Universal_Integer);
3256 when Attribute_Pred =>
3259 Resolve (E1, P_Base_Type);
3260 Set_Etype (N, P_Base_Type);
3262 -- Nothing to do for real type case
3264 if Is_Real_Type (P_Type) then
3267 -- If not modular type, test for overflow check required
3270 if not Is_Modular_Integer_Type (P_Type)
3271 and then not Range_Checks_Suppressed (P_Base_Type)
3273 Enable_Range_Check (E1);
3281 when Attribute_Range =>
3282 Check_Array_Or_Scalar_Type;
3284 if Ada_Version = Ada_83
3285 and then Is_Scalar_Type (P_Type)
3286 and then Comes_From_Source (N)
3289 ("(Ada 83) % attribute not allowed for scalar type", P);
3296 when Attribute_Range_Length =>
3297 Check_Discrete_Type;
3298 Set_Etype (N, Universal_Integer);
3304 when Attribute_Read =>
3306 Check_Stream_Attribute (TSS_Stream_Read);
3307 Set_Etype (N, Standard_Void_Type);
3308 Resolve (N, Standard_Void_Type);
3309 Note_Possible_Modification (E2);
3315 when Attribute_Remainder =>
3316 Check_Floating_Point_Type_2;
3317 Set_Etype (N, P_Base_Type);
3318 Resolve (E1, P_Base_Type);
3319 Resolve (E2, P_Base_Type);
3325 when Attribute_Round =>
3327 Check_Decimal_Fixed_Point_Type;
3328 Set_Etype (N, P_Base_Type);
3330 -- Because the context is universal_real (3.5.10(12)) it is a legal
3331 -- context for a universal fixed expression. This is the only
3332 -- attribute whose functional description involves U_R.
3334 if Etype (E1) = Universal_Fixed then
3336 Conv : constant Node_Id := Make_Type_Conversion (Loc,
3337 Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
3338 Expression => Relocate_Node (E1));
3346 Resolve (E1, Any_Real);
3352 when Attribute_Rounding =>
3353 Check_Floating_Point_Type_1;
3354 Set_Etype (N, P_Base_Type);
3355 Resolve (E1, P_Base_Type);
3361 when Attribute_Safe_Emax =>
3362 Check_Floating_Point_Type_0;
3363 Set_Etype (N, Universal_Integer);
3369 when Attribute_Safe_First =>
3370 Check_Floating_Point_Type_0;
3371 Set_Etype (N, Universal_Real);
3377 when Attribute_Safe_Large =>
3380 Set_Etype (N, Universal_Real);
3386 when Attribute_Safe_Last =>
3387 Check_Floating_Point_Type_0;
3388 Set_Etype (N, Universal_Real);
3394 when Attribute_Safe_Small =>
3397 Set_Etype (N, Universal_Real);
3403 when Attribute_Scale =>
3405 Check_Decimal_Fixed_Point_Type;
3406 Set_Etype (N, Universal_Integer);
3412 when Attribute_Scaling =>
3413 Check_Floating_Point_Type_2;
3414 Set_Etype (N, P_Base_Type);
3415 Resolve (E1, P_Base_Type);
3421 when Attribute_Signed_Zeros =>
3422 Check_Floating_Point_Type_0;
3423 Set_Etype (N, Standard_Boolean);
3429 when Attribute_Size | Attribute_VADS_Size =>
3432 -- If prefix is parameterless function call, rewrite and resolve
3435 if Is_Entity_Name (P)
3436 and then Ekind (Entity (P)) = E_Function
3440 -- Similar processing for a protected function call
3442 elsif Nkind (P) = N_Selected_Component
3443 and then Ekind (Entity (Selector_Name (P))) = E_Function
3448 if Is_Object_Reference (P) then
3449 Check_Object_Reference (P);
3451 elsif Is_Entity_Name (P)
3452 and then Is_Type (Entity (P))
3456 elsif Nkind (P) = N_Type_Conversion
3457 and then not Comes_From_Source (P)
3462 Error_Attr ("invalid prefix for % attribute", P);
3465 Check_Not_Incomplete_Type;
3466 Set_Etype (N, Universal_Integer);
3472 when Attribute_Small =>
3475 Set_Etype (N, Universal_Real);
3481 when Attribute_Storage_Pool =>
3482 if Is_Access_Type (P_Type) then
3485 -- Set appropriate entity
3487 if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
3488 Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
3490 Set_Entity (N, RTE (RE_Global_Pool_Object));
3493 Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
3495 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
3496 -- Storage_Pool since this attribute is not defined for such
3497 -- types (RM E.2.3(22)).
3499 Validate_Remote_Access_To_Class_Wide_Type (N);
3502 Error_Attr ("prefix of % attribute must be access type", P);
3509 when Attribute_Storage_Size =>
3511 if Is_Task_Type (P_Type) then
3513 Set_Etype (N, Universal_Integer);
3515 elsif Is_Access_Type (P_Type) then
3516 if Is_Entity_Name (P)
3517 and then Is_Type (Entity (P))
3521 Set_Etype (N, Universal_Integer);
3523 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
3524 -- Storage_Size since this attribute is not defined for
3525 -- such types (RM E.2.3(22)).
3527 Validate_Remote_Access_To_Class_Wide_Type (N);
3529 -- The prefix is allowed to be an implicit dereference
3530 -- of an access value designating a task.
3535 Set_Etype (N, Universal_Integer);
3540 ("prefix of % attribute must be access or task type", P);
3547 when Attribute_Storage_Unit =>
3548 Standard_Attribute (Ttypes.System_Storage_Unit);
3554 when Attribute_Stream_Size =>
3558 if Is_Entity_Name (P)
3559 and then Is_Elementary_Type (Entity (P))
3561 Set_Etype (N, Universal_Integer);
3563 Error_Attr ("invalid prefix for % attribute", P);
3570 when Attribute_Succ =>
3573 Resolve (E1, P_Base_Type);
3574 Set_Etype (N, P_Base_Type);
3576 -- Nothing to do for real type case
3578 if Is_Real_Type (P_Type) then
3581 -- If not modular type, test for overflow check required
3584 if not Is_Modular_Integer_Type (P_Type)
3585 and then not Range_Checks_Suppressed (P_Base_Type)
3587 Enable_Range_Check (E1);
3595 when Attribute_Tag =>
3599 if not Is_Tagged_Type (P_Type) then
3600 Error_Attr ("prefix of % attribute must be tagged", P);
3602 -- Next test does not apply to generated code
3603 -- why not, and what does the illegal reference mean???
3605 elsif Is_Object_Reference (P)
3606 and then not Is_Class_Wide_Type (P_Type)
3607 and then Comes_From_Source (N)
3610 ("% attribute can only be applied to objects of class-wide type",
3614 Set_Etype (N, RTE (RE_Tag));
3620 when Attribute_Target_Name => Target_Name : declare
3621 TN : constant String := Sdefault.Target_Name.all;
3625 Check_Standard_Prefix;
3630 if TN (TL) = '/' or else TN (TL) = '\' then
3635 Make_String_Literal (Loc,
3636 Strval => TN (TN'First .. TL)));
3637 Analyze_And_Resolve (N, Standard_String);
3644 when Attribute_Terminated =>
3646 Set_Etype (N, Standard_Boolean);
3653 when Attribute_To_Address =>
3657 if Nkind (P) /= N_Identifier
3658 or else Chars (P) /= Name_System
3660 Error_Attr ("prefix of %attribute must be System", P);
3663 Generate_Reference (RTE (RE_Address), P);
3664 Analyze_And_Resolve (E1, Any_Integer);
3665 Set_Etype (N, RTE (RE_Address));
3671 when Attribute_Truncation =>
3672 Check_Floating_Point_Type_1;
3673 Resolve (E1, P_Base_Type);
3674 Set_Etype (N, P_Base_Type);
3680 when Attribute_Type_Class =>
3683 Check_Not_Incomplete_Type;
3684 Set_Etype (N, RTE (RE_Type_Class));
3690 when Attribute_UET_Address =>
3692 Check_Unit_Name (P);
3693 Set_Etype (N, RTE (RE_Address));
3695 -----------------------
3696 -- Unbiased_Rounding --
3697 -----------------------
3699 when Attribute_Unbiased_Rounding =>
3700 Check_Floating_Point_Type_1;
3701 Set_Etype (N, P_Base_Type);
3702 Resolve (E1, P_Base_Type);
3704 ----------------------
3705 -- Unchecked_Access --
3706 ----------------------
3708 when Attribute_Unchecked_Access =>
3709 if Comes_From_Source (N) then
3710 Check_Restriction (No_Unchecked_Access, N);
3713 Analyze_Access_Attribute;
3715 -------------------------
3716 -- Unconstrained_Array --
3717 -------------------------
3719 when Attribute_Unconstrained_Array =>
3722 Check_Not_Incomplete_Type;
3723 Set_Etype (N, Standard_Boolean);
3725 ------------------------------
3726 -- Universal_Literal_String --
3727 ------------------------------
3729 -- This is a GNAT specific attribute whose prefix must be a named
3730 -- number where the expression is either a single numeric literal,
3731 -- or a numeric literal immediately preceded by a minus sign. The
3732 -- result is equivalent to a string literal containing the text of
3733 -- the literal as it appeared in the source program with a possible
3734 -- leading minus sign.
3736 when Attribute_Universal_Literal_String => Universal_Literal_String :
3740 if not Is_Entity_Name (P)
3741 or else Ekind (Entity (P)) not in Named_Kind
3743 Error_Attr ("prefix for % attribute must be named number", P);
3750 Src : Source_Buffer_Ptr;
3753 Expr := Original_Node (Expression (Parent (Entity (P))));
3755 if Nkind (Expr) = N_Op_Minus then
3757 Expr := Original_Node (Right_Opnd (Expr));
3762 if Nkind (Expr) /= N_Integer_Literal
3763 and then Nkind (Expr) /= N_Real_Literal
3766 ("named number for % attribute must be simple literal", N);
3769 -- Build string literal corresponding to source literal text
3774 Store_String_Char (Get_Char_Code ('-'));
3778 Src := Source_Text (Get_Source_File_Index (S));
3780 while Src (S) /= ';' and then Src (S) /= ' ' loop
3781 Store_String_Char (Get_Char_Code (Src (S)));
3785 -- Now we rewrite the attribute with the string literal
3788 Make_String_Literal (Loc, End_String));
3792 end Universal_Literal_String;
3794 -------------------------
3795 -- Unrestricted_Access --
3796 -------------------------
3798 -- This is a GNAT specific attribute which is like Access except that
3799 -- all scope checks and checks for aliased views are omitted.
3801 when Attribute_Unrestricted_Access =>
3802 if Comes_From_Source (N) then
3803 Check_Restriction (No_Unchecked_Access, N);
3806 if Is_Entity_Name (P) then
3807 Set_Address_Taken (Entity (P));
3810 Analyze_Access_Attribute;
3816 when Attribute_Val => Val : declare
3819 Check_Discrete_Type;
3820 Resolve (E1, Any_Integer);
3821 Set_Etype (N, P_Base_Type);
3823 -- Note, we need a range check in general, but we wait for the
3824 -- Resolve call to do this, since we want to let Eval_Attribute
3825 -- have a chance to find an static illegality first!
3832 when Attribute_Valid =>
3835 -- Ignore check for object if we have a 'Valid reference generated
3836 -- by the expanded code, since in some cases valid checks can occur
3837 -- on items that are names, but are not objects (e.g. attributes).
3839 if Comes_From_Source (N) then
3840 Check_Object_Reference (P);
3843 if not Is_Scalar_Type (P_Type) then
3844 Error_Attr ("object for % attribute must be of scalar type", P);
3847 Set_Etype (N, Standard_Boolean);
3853 when Attribute_Value => Value :
3858 if Is_Enumeration_Type (P_Type) then
3859 Check_Restriction (No_Enumeration_Maps, N);
3862 -- Set Etype before resolving expression because expansion of
3863 -- expression may require enclosing type. Note that the type
3864 -- returned by 'Value is the base type of the prefix type.
3866 Set_Etype (N, P_Base_Type);
3867 Validate_Non_Static_Attribute_Function_Call;
3874 when Attribute_Value_Size =>
3877 Check_Not_Incomplete_Type;
3878 Set_Etype (N, Universal_Integer);
3884 when Attribute_Version =>
3887 Set_Etype (N, RTE (RE_Version_String));
3893 when Attribute_Wchar_T_Size =>
3894 Standard_Attribute (Interfaces_Wchar_T_Size);
3900 when Attribute_Wide_Image => Wide_Image :
3903 Set_Etype (N, Standard_Wide_String);
3905 Resolve (E1, P_Base_Type);
3906 Validate_Non_Static_Attribute_Function_Call;
3909 ---------------------
3910 -- Wide_Wide_Image --
3911 ---------------------
3913 when Attribute_Wide_Wide_Image => Wide_Wide_Image :
3916 Set_Etype (N, Standard_Wide_Wide_String);
3918 Resolve (E1, P_Base_Type);
3919 Validate_Non_Static_Attribute_Function_Call;
3920 end Wide_Wide_Image;
3926 when Attribute_Wide_Value => Wide_Value :
3931 -- Set Etype before resolving expression because expansion
3932 -- of expression may require enclosing type.
3934 Set_Etype (N, P_Type);
3935 Validate_Non_Static_Attribute_Function_Call;
3938 ---------------------
3939 -- Wide_Wide_Value --
3940 ---------------------
3942 when Attribute_Wide_Wide_Value => Wide_Wide_Value :
3947 -- Set Etype before resolving expression because expansion
3948 -- of expression may require enclosing type.
3950 Set_Etype (N, P_Type);
3951 Validate_Non_Static_Attribute_Function_Call;
3952 end Wide_Wide_Value;
3954 ---------------------
3955 -- Wide_Wide_Width --
3956 ---------------------
3958 when Attribute_Wide_Wide_Width =>
3961 Set_Etype (N, Universal_Integer);
3967 when Attribute_Wide_Width =>
3970 Set_Etype (N, Universal_Integer);
3976 when Attribute_Width =>
3979 Set_Etype (N, Universal_Integer);
3985 when Attribute_Word_Size =>
3986 Standard_Attribute (System_Word_Size);
3992 when Attribute_Write =>
3994 Check_Stream_Attribute (TSS_Stream_Write);
3995 Set_Etype (N, Standard_Void_Type);
3996 Resolve (N, Standard_Void_Type);
4000 -- All errors raise Bad_Attribute, so that we get out before any further
4001 -- damage occurs when an error is detected (for example, if we check for
4002 -- one attribute expression, and the check succeeds, we want to be able
4003 -- to proceed securely assuming that an expression is in fact present.
4005 -- Note: we set the attribute analyzed in this case to prevent any
4006 -- attempt at reanalysis which could generate spurious error msgs.
4009 when Bad_Attribute =>
4011 Set_Etype (N, Any_Type);
4013 end Analyze_Attribute;
4015 --------------------
4016 -- Eval_Attribute --
4017 --------------------
4019 procedure Eval_Attribute (N : Node_Id) is
4020 Loc : constant Source_Ptr := Sloc (N);
4021 Aname : constant Name_Id := Attribute_Name (N);
4022 Id : constant Attribute_Id := Get_Attribute_Id (Aname);
4023 P : constant Node_Id := Prefix (N);
4025 C_Type : constant Entity_Id := Etype (N);
4026 -- The type imposed by the context
4029 -- First expression, or Empty if none
4032 -- Second expression, or Empty if none
4034 P_Entity : Entity_Id;
4035 -- Entity denoted by prefix
4038 -- The type of the prefix
4040 P_Base_Type : Entity_Id;
4041 -- The base type of the prefix type
4043 P_Root_Type : Entity_Id;
4044 -- The root type of the prefix type
4047 -- True if the result is Static. This is set by the general processing
4048 -- to true if the prefix is static, and all expressions are static. It
4049 -- can be reset as processing continues for particular attributes
4051 Lo_Bound, Hi_Bound : Node_Id;
4052 -- Expressions for low and high bounds of type or array index referenced
4053 -- by First, Last, or Length attribute for array, set by Set_Bounds.
4056 -- Constraint error node used if we have an attribute reference has
4057 -- an argument that raises a constraint error. In this case we replace
4058 -- the attribute with a raise constraint_error node. This is important
4059 -- processing, since otherwise gigi might see an attribute which it is
4060 -- unprepared to deal with.
4062 function Aft_Value return Nat;
4063 -- Computes Aft value for current attribute prefix (used by Aft itself
4064 -- and also by Width for computing the Width of a fixed point type).
4066 procedure Check_Expressions;
4067 -- In case where the attribute is not foldable, the expressions, if
4068 -- any, of the attribute, are in a non-static context. This procedure
4069 -- performs the required additional checks.
4071 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
4072 -- Determines if the given type has compile time known bounds. Note
4073 -- that we enter the case statement even in cases where the prefix
4074 -- type does NOT have known bounds, so it is important to guard any
4075 -- attempt to evaluate both bounds with a call to this function.
4077 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
4078 -- This procedure is called when the attribute N has a non-static
4079 -- but compile time known value given by Val. It includes the
4080 -- necessary checks for out of range values.
4082 procedure Float_Attribute_Universal_Integer
4091 -- This procedure evaluates a float attribute with no arguments that
4092 -- returns a universal integer result. The parameters give the values
4093 -- for the possible floating-point root types. See ttypef for details.
4094 -- The prefix type is a float type (and is thus not a generic type).
4096 procedure Float_Attribute_Universal_Real
4097 (IEEES_Val : String;
4104 AAMPL_Val : String);
4105 -- This procedure evaluates a float attribute with no arguments that
4106 -- returns a universal real result. The parameters give the values
4107 -- required for the possible floating-point root types in string
4108 -- format as real literals with a possible leading minus sign.
4109 -- The prefix type is a float type (and is thus not a generic type).
4111 function Fore_Value return Nat;
4112 -- Computes the Fore value for the current attribute prefix, which is
4113 -- known to be a static fixed-point type. Used by Fore and Width.
4115 function Mantissa return Uint;
4116 -- Returns the Mantissa value for the prefix type
4118 procedure Set_Bounds;
4119 -- Used for First, Last and Length attributes applied to an array or
4120 -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
4121 -- and high bound expressions for the index referenced by the attribute
4122 -- designator (i.e. the first index if no expression is present, and
4123 -- the N'th index if the value N is present as an expression). Also
4124 -- used for First and Last of scalar types. Static is reset to False
4125 -- if the type or index type is not statically constrained.
4131 function Aft_Value return Nat is
4137 Delta_Val := Delta_Value (P_Type);
4139 while Delta_Val < Ureal_Tenth loop
4140 Delta_Val := Delta_Val * Ureal_10;
4141 Result := Result + 1;
4147 -----------------------
4148 -- Check_Expressions --
4149 -----------------------
4151 procedure Check_Expressions is
4155 while Present (E) loop
4156 Check_Non_Static_Context (E);
4159 end Check_Expressions;
4161 ----------------------------------
4162 -- Compile_Time_Known_Attribute --
4163 ----------------------------------
4165 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is
4166 T : constant Entity_Id := Etype (N);
4169 Fold_Uint (N, Val, False);
4171 -- Check that result is in bounds of the type if it is static
4173 if Is_In_Range (N, T) then
4176 elsif Is_Out_Of_Range (N, T) then
4177 Apply_Compile_Time_Constraint_Error
4178 (N, "value not in range of}?", CE_Range_Check_Failed);
4180 elsif not Range_Checks_Suppressed (T) then
4181 Enable_Range_Check (N);
4184 Set_Do_Range_Check (N, False);
4186 end Compile_Time_Known_Attribute;
4188 -------------------------------
4189 -- Compile_Time_Known_Bounds --
4190 -------------------------------
4192 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
4195 Compile_Time_Known_Value (Type_Low_Bound (Typ))
4197 Compile_Time_Known_Value (Type_High_Bound (Typ));
4198 end Compile_Time_Known_Bounds;
4200 ---------------------------------------
4201 -- Float_Attribute_Universal_Integer --
4202 ---------------------------------------
4204 procedure Float_Attribute_Universal_Integer
4215 Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
4218 if Vax_Float (P_Base_Type) then
4219 if Digs = VAXFF_Digits then
4221 elsif Digs = VAXDF_Digits then
4223 else pragma Assert (Digs = VAXGF_Digits);
4227 elsif Is_AAMP_Float (P_Base_Type) then
4228 if Digs = AAMPS_Digits then
4230 else pragma Assert (Digs = AAMPL_Digits);
4235 if Digs = IEEES_Digits then
4237 elsif Digs = IEEEL_Digits then
4239 else pragma Assert (Digs = IEEEX_Digits);
4244 Fold_Uint (N, UI_From_Int (Val), True);
4245 end Float_Attribute_Universal_Integer;
4247 ------------------------------------
4248 -- Float_Attribute_Universal_Real --
4249 ------------------------------------
4251 procedure Float_Attribute_Universal_Real
4252 (IEEES_Val : String;
4262 Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
4265 if Vax_Float (P_Base_Type) then
4266 if Digs = VAXFF_Digits then
4267 Val := Real_Convert (VAXFF_Val);
4268 elsif Digs = VAXDF_Digits then
4269 Val := Real_Convert (VAXDF_Val);
4270 else pragma Assert (Digs = VAXGF_Digits);
4271 Val := Real_Convert (VAXGF_Val);
4274 elsif Is_AAMP_Float (P_Base_Type) then
4275 if Digs = AAMPS_Digits then
4276 Val := Real_Convert (AAMPS_Val);
4277 else pragma Assert (Digs = AAMPL_Digits);
4278 Val := Real_Convert (AAMPL_Val);
4282 if Digs = IEEES_Digits then
4283 Val := Real_Convert (IEEES_Val);
4284 elsif Digs = IEEEL_Digits then
4285 Val := Real_Convert (IEEEL_Val);
4286 else pragma Assert (Digs = IEEEX_Digits);
4287 Val := Real_Convert (IEEEX_Val);
4291 Set_Sloc (Val, Loc);
4293 Set_Is_Static_Expression (N, Static);
4294 Analyze_And_Resolve (N, C_Type);
4295 end Float_Attribute_Universal_Real;
4301 -- Note that the Fore calculation is based on the actual values
4302 -- of the bounds, and does not take into account possible rounding.
4304 function Fore_Value return Nat is
4305 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
4306 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
4307 Small : constant Ureal := Small_Value (P_Type);
4308 Lo_Real : constant Ureal := Lo * Small;
4309 Hi_Real : constant Ureal := Hi * Small;
4314 -- Bounds are given in terms of small units, so first compute
4315 -- proper values as reals.
4317 T := UR_Max (abs Lo_Real, abs Hi_Real);
4320 -- Loop to compute proper value if more than one digit required
4322 while T >= Ureal_10 loop
4334 -- Table of mantissa values accessed by function Computed using
4337 -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
4339 -- where D is T'Digits (RM83 3.5.7)
4341 Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
4383 function Mantissa return Uint is
4386 UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
4393 procedure Set_Bounds is
4399 -- For a string literal subtype, we have to construct the bounds.
4400 -- Valid Ada code never applies attributes to string literals, but
4401 -- it is convenient to allow the expander to generate attribute
4402 -- references of this type (e.g. First and Last applied to a string
4405 -- Note that the whole point of the E_String_Literal_Subtype is to
4406 -- avoid this construction of bounds, but the cases in which we
4407 -- have to materialize them are rare enough that we don't worry!
4409 -- The low bound is simply the low bound of the base type. The
4410 -- high bound is computed from the length of the string and this
4413 if Ekind (P_Type) = E_String_Literal_Subtype then
4414 Ityp := Etype (First_Index (Base_Type (P_Type)));
4415 Lo_Bound := Type_Low_Bound (Ityp);
4418 Make_Integer_Literal (Sloc (P),
4420 Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
4422 Set_Parent (Hi_Bound, P);
4423 Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
4426 -- For non-array case, just get bounds of scalar type
4428 elsif Is_Scalar_Type (P_Type) then
4431 -- For a fixed-point type, we must freeze to get the attributes
4432 -- of the fixed-point type set now so we can reference them.
4434 if Is_Fixed_Point_Type (P_Type)
4435 and then not Is_Frozen (Base_Type (P_Type))
4436 and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
4437 and then Compile_Time_Known_Value (Type_High_Bound (P_Type))
4439 Freeze_Fixed_Point_Type (Base_Type (P_Type));
4442 -- For array case, get type of proper index
4448 Ndim := UI_To_Int (Expr_Value (E1));
4451 Indx := First_Index (P_Type);
4452 for J in 1 .. Ndim - 1 loop
4456 -- If no index type, get out (some other error occurred, and
4457 -- we don't have enough information to complete the job!)
4465 Ityp := Etype (Indx);
4468 -- A discrete range in an index constraint is allowed to be a
4469 -- subtype indication. This is syntactically a pain, but should
4470 -- not propagate to the entity for the corresponding index subtype.
4471 -- After checking that the subtype indication is legal, the range
4472 -- of the subtype indication should be transfered to the entity.
4473 -- The attributes for the bounds should remain the simple retrievals
4474 -- that they are now.
4476 Lo_Bound := Type_Low_Bound (Ityp);
4477 Hi_Bound := Type_High_Bound (Ityp);
4479 if not Is_Static_Subtype (Ityp) then
4484 -- Start of processing for Eval_Attribute
4487 -- Acquire first two expressions (at the moment, no attributes
4488 -- take more than two expressions in any case).
4490 if Present (Expressions (N)) then
4491 E1 := First (Expressions (N));
4498 -- Special processing for cases where the prefix is an object. For
4499 -- this purpose, a string literal counts as an object (attributes
4500 -- of string literals can only appear in generated code).
4502 if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
4504 -- For Component_Size, the prefix is an array object, and we apply
4505 -- the attribute to the type of the object. This is allowed for
4506 -- both unconstrained and constrained arrays, since the bounds
4507 -- have no influence on the value of this attribute.
4509 if Id = Attribute_Component_Size then
4510 P_Entity := Etype (P);
4512 -- For First and Last, the prefix is an array object, and we apply
4513 -- the attribute to the type of the array, but we need a constrained
4514 -- type for this, so we use the actual subtype if available.
4516 elsif Id = Attribute_First
4520 Id = Attribute_Length
4523 AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
4526 if Present (AS) and then Is_Constrained (AS) then
4529 -- If we have an unconstrained type, cannot fold
4537 -- For Size, give size of object if available, otherwise we
4538 -- cannot fold Size.
4540 elsif Id = Attribute_Size then
4541 if Is_Entity_Name (P)
4542 and then Known_Esize (Entity (P))
4544 Compile_Time_Known_Attribute (N, Esize (Entity (P)));
4552 -- For Alignment, give size of object if available, otherwise we
4553 -- cannot fold Alignment.
4555 elsif Id = Attribute_Alignment then
4556 if Is_Entity_Name (P)
4557 and then Known_Alignment (Entity (P))
4559 Fold_Uint (N, Alignment (Entity (P)), False);
4567 -- No other attributes for objects are folded
4574 -- Cases where P is not an object. Cannot do anything if P is
4575 -- not the name of an entity.
4577 elsif not Is_Entity_Name (P) then
4581 -- Otherwise get prefix entity
4584 P_Entity := Entity (P);
4587 -- At this stage P_Entity is the entity to which the attribute
4588 -- is to be applied. This is usually simply the entity of the
4589 -- prefix, except in some cases of attributes for objects, where
4590 -- as described above, we apply the attribute to the object type.
4592 -- First foldable possibility is a scalar or array type (RM 4.9(7))
4593 -- that is not generic (generic types are eliminated by RM 4.9(25)).
4594 -- Note we allow non-static non-generic types at this stage as further
4597 if Is_Type (P_Entity)
4598 and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
4599 and then (not Is_Generic_Type (P_Entity))
4603 -- Second foldable possibility is an array object (RM 4.9(8))
4605 elsif (Ekind (P_Entity) = E_Variable
4607 Ekind (P_Entity) = E_Constant)
4608 and then Is_Array_Type (Etype (P_Entity))
4609 and then (not Is_Generic_Type (Etype (P_Entity)))
4611 P_Type := Etype (P_Entity);
4613 -- If the entity is an array constant with an unconstrained
4614 -- nominal subtype then get the type from the initial value.
4615 -- If the value has been expanded into assignments, the expression
4616 -- is not present and the attribute reference remains dynamic.
4617 -- We could do better here and retrieve the type ???
4619 if Ekind (P_Entity) = E_Constant
4620 and then not Is_Constrained (P_Type)
4622 if No (Constant_Value (P_Entity)) then
4625 P_Type := Etype (Constant_Value (P_Entity));
4629 -- Definite must be folded if the prefix is not a generic type,
4630 -- that is to say if we are within an instantiation. Same processing
4631 -- applies to the GNAT attributes Has_Discriminants, Type_Class,
4632 -- and Unconstrained_Array.
4634 elsif (Id = Attribute_Definite
4636 Id = Attribute_Has_Access_Values
4638 Id = Attribute_Has_Discriminants
4640 Id = Attribute_Type_Class
4642 Id = Attribute_Unconstrained_Array)
4643 and then not Is_Generic_Type (P_Entity)
4647 -- We can fold 'Size applied to a type if the size is known
4648 -- (as happens for a size from an attribute definition clause).
4649 -- At this stage, this can happen only for types (e.g. record
4650 -- types) for which the size is always non-static. We exclude
4651 -- generic types from consideration (since they have bogus
4652 -- sizes set within templates).
4654 elsif Id = Attribute_Size
4655 and then Is_Type (P_Entity)
4656 and then (not Is_Generic_Type (P_Entity))
4657 and then Known_Static_RM_Size (P_Entity)
4659 Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
4662 -- We can fold 'Alignment applied to a type if the alignment is known
4663 -- (as happens for an alignment from an attribute definition clause).
4664 -- At this stage, this can happen only for types (e.g. record
4665 -- types) for which the size is always non-static. We exclude
4666 -- generic types from consideration (since they have bogus
4667 -- sizes set within templates).
4669 elsif Id = Attribute_Alignment
4670 and then Is_Type (P_Entity)
4671 and then (not Is_Generic_Type (P_Entity))
4672 and then Known_Alignment (P_Entity)
4674 Compile_Time_Known_Attribute (N, Alignment (P_Entity));
4677 -- If this is an access attribute that is known to fail accessibility
4678 -- check, rewrite accordingly.
4680 elsif Attribute_Name (N) = Name_Access
4681 and then Raises_Constraint_Error (N)
4684 Make_Raise_Program_Error (Loc,
4685 Reason => PE_Accessibility_Check_Failed));
4686 Set_Etype (N, C_Type);
4689 -- No other cases are foldable (they certainly aren't static, and at
4690 -- the moment we don't try to fold any cases other than these three).
4697 -- If either attribute or the prefix is Any_Type, then propagate
4698 -- Any_Type to the result and don't do anything else at all.
4700 if P_Type = Any_Type
4701 or else (Present (E1) and then Etype (E1) = Any_Type)
4702 or else (Present (E2) and then Etype (E2) = Any_Type)
4704 Set_Etype (N, Any_Type);
4708 -- Scalar subtype case. We have not yet enforced the static requirement
4709 -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases
4710 -- of non-static attribute references (e.g. S'Digits for a non-static
4711 -- floating-point type, which we can compute at compile time).
4713 -- Note: this folding of non-static attributes is not simply a case of
4714 -- optimization. For many of the attributes affected, Gigi cannot handle
4715 -- the attribute and depends on the front end having folded them away.
4717 -- Note: although we don't require staticness at this stage, we do set
4718 -- the Static variable to record the staticness, for easy reference by
4719 -- those attributes where it matters (e.g. Succ and Pred), and also to
4720 -- be used to ensure that non-static folded things are not marked as
4721 -- being static (a check that is done right at the end).
4723 P_Root_Type := Root_Type (P_Type);
4724 P_Base_Type := Base_Type (P_Type);
4726 -- If the root type or base type is generic, then we cannot fold. This
4727 -- test is needed because subtypes of generic types are not always
4728 -- marked as being generic themselves (which seems odd???)
4730 if Is_Generic_Type (P_Root_Type)
4731 or else Is_Generic_Type (P_Base_Type)
4736 if Is_Scalar_Type (P_Type) then
4737 Static := Is_OK_Static_Subtype (P_Type);
4739 -- Array case. We enforce the constrained requirement of (RM 4.9(7-8))
4740 -- since we can't do anything with unconstrained arrays. In addition,
4741 -- only the First, Last and Length attributes are possibly static.
4742 -- In addition Component_Size is possibly foldable, even though it
4743 -- can never be static.
4745 -- Definite, Has_Access_Values, Has_Discriminants, Type_Class, and
4746 -- Unconstrained_Array are again exceptions, because they apply as
4747 -- well to unconstrained types.
4749 elsif Id = Attribute_Definite
4751 Id = Attribute_Has_Access_Values
4753 Id = Attribute_Has_Discriminants
4755 Id = Attribute_Type_Class
4757 Id = Attribute_Unconstrained_Array
4762 if not Is_Constrained (P_Type)
4763 or else (Id /= Attribute_Component_Size and then
4764 Id /= Attribute_First and then
4765 Id /= Attribute_Last and then
4766 Id /= Attribute_Length)
4772 -- The rules in (RM 4.9(7,8)) require a static array, but as in the
4773 -- scalar case, we hold off on enforcing staticness, since there are
4774 -- cases which we can fold at compile time even though they are not
4775 -- static (e.g. 'Length applied to a static index, even though other
4776 -- non-static indexes make the array type non-static). This is only
4777 -- an optimization, but it falls out essentially free, so why not.
4778 -- Again we compute the variable Static for easy reference later
4779 -- (note that no array attributes are static in Ada 83).
4781 Static := Ada_Version >= Ada_95;
4787 N := First_Index (P_Type);
4788 while Present (N) loop
4789 Static := Static and then Is_Static_Subtype (Etype (N));
4791 -- If however the index type is generic, attributes cannot
4794 if Is_Generic_Type (Etype (N))
4795 and then Id /= Attribute_Component_Size
4805 -- Check any expressions that are present. Note that these expressions,
4806 -- depending on the particular attribute type, are either part of the
4807 -- attribute designator, or they are arguments in a case where the
4808 -- attribute reference returns a function. In the latter case, the
4809 -- rule in (RM 4.9(22)) applies and in particular requires the type
4810 -- of the expressions to be scalar in order for the attribute to be
4811 -- considered to be static.
4818 while Present (E) loop
4820 -- If expression is not static, then the attribute reference
4821 -- result certainly cannot be static.
4823 if not Is_Static_Expression (E) then
4827 -- If the result is not known at compile time, or is not of
4828 -- a scalar type, then the result is definitely not static,
4829 -- so we can quit now.
4831 if not Compile_Time_Known_Value (E)
4832 or else not Is_Scalar_Type (Etype (E))
4834 -- An odd special case, if this is a Pos attribute, this
4835 -- is where we need to apply a range check since it does
4836 -- not get done anywhere else.
4838 if Id = Attribute_Pos then
4839 if Is_Integer_Type (Etype (E)) then
4840 Apply_Range_Check (E, Etype (N));
4847 -- If the expression raises a constraint error, then so does
4848 -- the attribute reference. We keep going in this case because
4849 -- we are still interested in whether the attribute reference
4850 -- is static even if it is not static.
4852 elsif Raises_Constraint_Error (E) then
4853 Set_Raises_Constraint_Error (N);
4859 if Raises_Constraint_Error (Prefix (N)) then
4864 -- Deal with the case of a static attribute reference that raises
4865 -- constraint error. The Raises_Constraint_Error flag will already
4866 -- have been set, and the Static flag shows whether the attribute
4867 -- reference is static. In any case we certainly can't fold such an
4868 -- attribute reference.
4870 -- Note that the rewriting of the attribute node with the constraint
4871 -- error node is essential in this case, because otherwise Gigi might
4872 -- blow up on one of the attributes it never expects to see.
4874 -- The constraint_error node must have the type imposed by the context,
4875 -- to avoid spurious errors in the enclosing expression.
4877 if Raises_Constraint_Error (N) then
4879 Make_Raise_Constraint_Error (Sloc (N),
4880 Reason => CE_Range_Check_Failed);
4881 Set_Etype (CE_Node, Etype (N));
4882 Set_Raises_Constraint_Error (CE_Node);
4884 Rewrite (N, Relocate_Node (CE_Node));
4885 Set_Is_Static_Expression (N, Static);
4889 -- At this point we have a potentially foldable attribute reference.
4890 -- If Static is set, then the attribute reference definitely obeys
4891 -- the requirements in (RM 4.9(7,8,22)), and it definitely can be
4892 -- folded. If Static is not set, then the attribute may or may not
4893 -- be foldable, and the individual attribute processing routines
4894 -- test Static as required in cases where it makes a difference.
4896 -- In the case where Static is not set, we do know that all the
4897 -- expressions present are at least known at compile time (we
4898 -- assumed above that if this was not the case, then there was
4899 -- no hope of static evaluation). However, we did not require
4900 -- that the bounds of the prefix type be compile time known,
4901 -- let alone static). That's because there are many attributes
4902 -- that can be computed at compile time on non-static subtypes,
4903 -- even though such references are not static expressions.
4911 when Attribute_Adjacent =>
4914 (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
4920 when Attribute_Aft =>
4921 Fold_Uint (N, UI_From_Int (Aft_Value), True);
4927 when Attribute_Alignment => Alignment_Block : declare
4928 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
4931 -- Fold if alignment is set and not otherwise
4933 if Known_Alignment (P_TypeA) then
4934 Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA));
4936 end Alignment_Block;
4942 -- Can only be folded in No_Ast_Handler case
4944 when Attribute_AST_Entry =>
4945 if not Is_AST_Entry (P_Entity) then
4947 New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc));
4956 -- Bit can never be folded
4958 when Attribute_Bit =>
4965 -- Body_version can never be static
4967 when Attribute_Body_Version =>
4974 when Attribute_Ceiling =>
4976 Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)), Static);
4978 --------------------
4979 -- Component_Size --
4980 --------------------
4982 when Attribute_Component_Size =>
4983 if Known_Static_Component_Size (P_Type) then
4984 Fold_Uint (N, Component_Size (P_Type), False);
4991 when Attribute_Compose =>
4994 (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)),
5001 -- Constrained is never folded for now, there may be cases that
5002 -- could be handled at compile time. to be looked at later.
5004 when Attribute_Constrained =>
5011 when Attribute_Copy_Sign =>
5014 (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
5020 when Attribute_Delta =>
5021 Fold_Ureal (N, Delta_Value (P_Type), True);
5027 when Attribute_Definite =>
5028 Rewrite (N, New_Occurrence_Of (
5029 Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
5030 Analyze_And_Resolve (N, Standard_Boolean);
5036 when Attribute_Denorm =>
5038 (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True);
5044 when Attribute_Digits =>
5045 Fold_Uint (N, Digits_Value (P_Type), True);
5051 when Attribute_Emax =>
5053 -- Ada 83 attribute is defined as (RM83 3.5.8)
5055 -- T'Emax = 4 * T'Mantissa
5057 Fold_Uint (N, 4 * Mantissa, True);
5063 when Attribute_Enum_Rep =>
5065 -- For an enumeration type with a non-standard representation use
5066 -- the Enumeration_Rep field of the proper constant. Note that this
5067 -- will not work for types Character/Wide_[Wide-]Character, since no
5068 -- real entities are created for the enumeration literals, but that
5069 -- does not matter since these two types do not have non-standard
5070 -- representations anyway.
5072 if Is_Enumeration_Type (P_Type)
5073 and then Has_Non_Standard_Rep (P_Type)
5075 Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static);
5077 -- For enumeration types with standard representations and all
5078 -- other cases (i.e. all integer and modular types), Enum_Rep
5079 -- is equivalent to Pos.
5082 Fold_Uint (N, Expr_Value (E1), Static);
5089 when Attribute_Epsilon =>
5091 -- Ada 83 attribute is defined as (RM83 3.5.8)
5093 -- T'Epsilon = 2.0**(1 - T'Mantissa)
5095 Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
5101 when Attribute_Exponent =>
5103 Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)), Static);
5109 when Attribute_First => First_Attr :
5113 if Compile_Time_Known_Value (Lo_Bound) then
5114 if Is_Real_Type (P_Type) then
5115 Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
5117 Fold_Uint (N, Expr_Value (Lo_Bound), Static);
5126 when Attribute_Fixed_Value =>
5133 when Attribute_Floor =>
5135 Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)), Static);
5141 when Attribute_Fore =>
5142 if Compile_Time_Known_Bounds (P_Type) then
5143 Fold_Uint (N, UI_From_Int (Fore_Value), Static);
5150 when Attribute_Fraction =>
5152 Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static);
5154 -----------------------
5155 -- Has_Access_Values --
5156 -----------------------
5158 when Attribute_Has_Access_Values =>
5159 Rewrite (N, New_Occurrence_Of
5160 (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
5161 Analyze_And_Resolve (N, Standard_Boolean);
5163 -----------------------
5164 -- Has_Discriminants --
5165 -----------------------
5167 when Attribute_Has_Discriminants =>
5168 Rewrite (N, New_Occurrence_Of (
5169 Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
5170 Analyze_And_Resolve (N, Standard_Boolean);
5176 when Attribute_Identity =>
5183 -- Image is a scalar attribute, but is never static, because it is
5184 -- not a static function (having a non-scalar argument (RM 4.9(22))
5186 when Attribute_Image =>
5193 -- Img is a scalar attribute, but is never static, because it is
5194 -- not a static function (having a non-scalar argument (RM 4.9(22))
5196 when Attribute_Img =>
5203 when Attribute_Integer_Value =>
5210 when Attribute_Large =>
5212 -- For fixed-point, we use the identity:
5214 -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small
5216 if Is_Fixed_Point_Type (P_Type) then
5218 Make_Op_Multiply (Loc,
5220 Make_Op_Subtract (Loc,
5224 Make_Real_Literal (Loc, Ureal_2),
5226 Make_Attribute_Reference (Loc,
5228 Attribute_Name => Name_Mantissa)),
5229 Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
5232 Make_Real_Literal (Loc, Small_Value (Entity (P)))));
5234 Analyze_And_Resolve (N, C_Type);
5236 -- Floating-point (Ada 83 compatibility)
5239 -- Ada 83 attribute is defined as (RM83 3.5.8)
5241 -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
5245 -- T'Emax = 4 * T'Mantissa
5248 Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
5256 when Attribute_Last => Last :
5260 if Compile_Time_Known_Value (Hi_Bound) then
5261 if Is_Real_Type (P_Type) then
5262 Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
5264 Fold_Uint (N, Expr_Value (Hi_Bound), Static);
5273 when Attribute_Leading_Part =>
5275 Eval_Fat.Leading_Part
5276 (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
5282 when Attribute_Length => Length : declare
5286 -- In the case of a generic index type, the bounds may
5287 -- appear static but the computation is not meaningful,
5288 -- and may generate a spurious warning.
5290 Ind := First_Index (P_Type);
5292 while Present (Ind) loop
5293 if Is_Generic_Type (Etype (Ind)) then
5302 if Compile_Time_Known_Value (Lo_Bound)
5303 and then Compile_Time_Known_Value (Hi_Bound)
5306 UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
5315 when Attribute_Machine =>
5318 (P_Root_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
5325 when Attribute_Machine_Emax =>
5326 Float_Attribute_Universal_Integer (
5334 AAMPL_Machine_Emax);
5340 when Attribute_Machine_Emin =>
5341 Float_Attribute_Universal_Integer (
5349 AAMPL_Machine_Emin);
5351 ----------------------
5352 -- Machine_Mantissa --
5353 ----------------------
5355 when Attribute_Machine_Mantissa =>
5356 Float_Attribute_Universal_Integer (
5357 IEEES_Machine_Mantissa,
5358 IEEEL_Machine_Mantissa,
5359 IEEEX_Machine_Mantissa,
5360 VAXFF_Machine_Mantissa,
5361 VAXDF_Machine_Mantissa,
5362 VAXGF_Machine_Mantissa,
5363 AAMPS_Machine_Mantissa,
5364 AAMPL_Machine_Mantissa);
5366 -----------------------
5367 -- Machine_Overflows --
5368 -----------------------
5370 when Attribute_Machine_Overflows =>
5372 -- Always true for fixed-point
5374 if Is_Fixed_Point_Type (P_Type) then
5375 Fold_Uint (N, True_Value, True);
5377 -- Floating point case
5381 UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
5389 when Attribute_Machine_Radix =>
5390 if Is_Fixed_Point_Type (P_Type) then
5391 if Is_Decimal_Fixed_Point_Type (P_Type)
5392 and then Machine_Radix_10 (P_Type)
5394 Fold_Uint (N, Uint_10, True);
5396 Fold_Uint (N, Uint_2, True);
5399 -- All floating-point type always have radix 2
5402 Fold_Uint (N, Uint_2, True);
5405 --------------------
5406 -- Machine_Rounds --
5407 --------------------
5409 when Attribute_Machine_Rounds =>
5411 -- Always False for fixed-point
5413 if Is_Fixed_Point_Type (P_Type) then
5414 Fold_Uint (N, False_Value, True);
5416 -- Else yield proper floating-point result
5420 (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True);
5427 -- Note: Machine_Size is identical to Object_Size
5429 when Attribute_Machine_Size => Machine_Size : declare
5430 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
5433 if Known_Esize (P_TypeA) then
5434 Fold_Uint (N, Esize (P_TypeA), True);
5442 when Attribute_Mantissa =>
5444 -- Fixed-point mantissa
5446 if Is_Fixed_Point_Type (P_Type) then
5448 -- Compile time foldable case
5450 if Compile_Time_Known_Value (Type_Low_Bound (P_Type))
5452 Compile_Time_Known_Value (Type_High_Bound (P_Type))
5454 -- The calculation of the obsolete Ada 83 attribute Mantissa
5455 -- is annoying, because of AI00143, quoted here:
5457 -- !question 84-01-10
5459 -- Consider the model numbers for F:
5461 -- type F is delta 1.0 range -7.0 .. 8.0;
5463 -- The wording requires that F'MANTISSA be the SMALLEST
5464 -- integer number for which each bound of the specified
5465 -- range is either a model number or lies at most small
5466 -- distant from a model number. This means F'MANTISSA
5467 -- is required to be 3 since the range -7.0 .. 7.0 fits
5468 -- in 3 signed bits, and 8 is "at most" 1.0 from a model
5469 -- number, namely, 7. Is this analysis correct? Note that
5470 -- this implies the upper bound of the range is not
5471 -- represented as a model number.
5473 -- !response 84-03-17
5475 -- The analysis is correct. The upper and lower bounds for
5476 -- a fixed point type can lie outside the range of model
5487 LBound := Expr_Value_R (Type_Low_Bound (P_Type));
5488 UBound := Expr_Value_R (Type_High_Bound (P_Type));
5489 Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
5490 Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
5492 -- If the Bound is exactly a model number, i.e. a multiple
5493 -- of Small, then we back it off by one to get the integer
5494 -- value that must be representable.
5496 if Small_Value (P_Type) * Max_Man = Bound then
5497 Max_Man := Max_Man - 1;
5500 -- Now find corresponding size = Mantissa value
5503 while 2 ** Siz < Max_Man loop
5507 Fold_Uint (N, Siz, True);
5511 -- The case of dynamic bounds cannot be evaluated at compile
5512 -- time. Instead we use a runtime routine (see Exp_Attr).
5517 -- Floating-point Mantissa
5520 Fold_Uint (N, Mantissa, True);
5527 when Attribute_Max => Max :
5529 if Is_Real_Type (P_Type) then
5531 (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
5533 Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
5537 ----------------------------------
5538 -- Max_Size_In_Storage_Elements --
5539 ----------------------------------
5541 -- Max_Size_In_Storage_Elements is simply the Size rounded up to a
5542 -- Storage_Unit boundary. We can fold any cases for which the size
5543 -- is known by the front end.
5545 when Attribute_Max_Size_In_Storage_Elements =>
5546 if Known_Esize (P_Type) then
5548 (Esize (P_Type) + System_Storage_Unit - 1) /
5549 System_Storage_Unit,
5553 --------------------
5554 -- Mechanism_Code --
5555 --------------------
5557 when Attribute_Mechanism_Code =>
5561 Mech : Mechanism_Type;
5565 Mech := Mechanism (P_Entity);
5568 Val := UI_To_Int (Expr_Value (E1));
5570 Formal := First_Formal (P_Entity);
5571 for J in 1 .. Val - 1 loop
5572 Next_Formal (Formal);
5574 Mech := Mechanism (Formal);
5578 Fold_Uint (N, UI_From_Int (Int (-Mech)), True);
5586 when Attribute_Min => Min :
5588 if Is_Real_Type (P_Type) then
5590 (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
5593 (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
5601 when Attribute_Mod =>
5603 (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static);
5609 when Attribute_Model =>
5611 Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)), Static);
5617 when Attribute_Model_Emin =>
5618 Float_Attribute_Universal_Integer (
5632 when Attribute_Model_Epsilon =>
5633 Float_Attribute_Universal_Real (
5634 IEEES_Model_Epsilon'Universal_Literal_String,
5635 IEEEL_Model_Epsilon'Universal_Literal_String,
5636 IEEEX_Model_Epsilon'Universal_Literal_String,
5637 VAXFF_Model_Epsilon'Universal_Literal_String,
5638 VAXDF_Model_Epsilon'Universal_Literal_String,
5639 VAXGF_Model_Epsilon'Universal_Literal_String,
5640 AAMPS_Model_Epsilon'Universal_Literal_String,
5641 AAMPL_Model_Epsilon'Universal_Literal_String);
5643 --------------------
5644 -- Model_Mantissa --
5645 --------------------
5647 when Attribute_Model_Mantissa =>
5648 Float_Attribute_Universal_Integer (
5649 IEEES_Model_Mantissa,
5650 IEEEL_Model_Mantissa,
5651 IEEEX_Model_Mantissa,
5652 VAXFF_Model_Mantissa,
5653 VAXDF_Model_Mantissa,
5654 VAXGF_Model_Mantissa,
5655 AAMPS_Model_Mantissa,
5656 AAMPL_Model_Mantissa);
5662 when Attribute_Model_Small =>
5663 Float_Attribute_Universal_Real (
5664 IEEES_Model_Small'Universal_Literal_String,
5665 IEEEL_Model_Small'Universal_Literal_String,
5666 IEEEX_Model_Small'Universal_Literal_String,
5667 VAXFF_Model_Small'Universal_Literal_String,
5668 VAXDF_Model_Small'Universal_Literal_String,
5669 VAXGF_Model_Small'Universal_Literal_String,
5670 AAMPS_Model_Small'Universal_Literal_String,
5671 AAMPL_Model_Small'Universal_Literal_String);
5677 when Attribute_Modulus =>
5678 Fold_Uint (N, Modulus (P_Type), True);
5680 --------------------
5681 -- Null_Parameter --
5682 --------------------
5684 -- Cannot fold, we know the value sort of, but the whole point is
5685 -- that there is no way to talk about this imaginary value except
5686 -- by using the attribute, so we leave it the way it is.
5688 when Attribute_Null_Parameter =>
5695 -- The Object_Size attribute for a type returns the Esize of the
5696 -- type and can be folded if this value is known.
5698 when Attribute_Object_Size => Object_Size : declare
5699 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
5702 if Known_Esize (P_TypeA) then
5703 Fold_Uint (N, Esize (P_TypeA), True);
5707 -------------------------
5708 -- Passed_By_Reference --
5709 -------------------------
5711 -- Scalar types are never passed by reference
5713 when Attribute_Passed_By_Reference =>
5714 Fold_Uint (N, False_Value, True);
5720 when Attribute_Pos =>
5721 Fold_Uint (N, Expr_Value (E1), True);
5727 when Attribute_Pred => Pred :
5729 -- Floating-point case
5731 if Is_Floating_Point_Type (P_Type) then
5733 Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)), Static);
5737 elsif Is_Fixed_Point_Type (P_Type) then
5739 Expr_Value_R (E1) - Small_Value (P_Type), True);
5741 -- Modular integer case (wraps)
5743 elsif Is_Modular_Integer_Type (P_Type) then
5744 Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
5746 -- Other scalar cases
5749 pragma Assert (Is_Scalar_Type (P_Type));
5751 if Is_Enumeration_Type (P_Type)
5752 and then Expr_Value (E1) =
5753 Expr_Value (Type_Low_Bound (P_Base_Type))
5755 Apply_Compile_Time_Constraint_Error
5756 (N, "Pred of `&''First`",
5757 CE_Overflow_Check_Failed,
5759 Warn => not Static);
5765 Fold_Uint (N, Expr_Value (E1) - 1, Static);
5773 -- No processing required, because by this stage, Range has been
5774 -- replaced by First .. Last, so this branch can never be taken.
5776 when Attribute_Range =>
5777 raise Program_Error;
5783 when Attribute_Range_Length =>
5786 if Compile_Time_Known_Value (Hi_Bound)
5787 and then Compile_Time_Known_Value (Lo_Bound)
5791 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
5799 when Attribute_Remainder => Remainder : declare
5800 X : constant Ureal := Expr_Value_R (E1);
5801 Y : constant Ureal := Expr_Value_R (E2);
5804 if UR_Is_Zero (Y) then
5805 Apply_Compile_Time_Constraint_Error
5806 (N, "division by zero in Remainder",
5807 CE_Overflow_Check_Failed,
5808 Warn => not Static);
5814 Fold_Ureal (N, Eval_Fat.Remainder (P_Root_Type, X, Y), Static);
5821 when Attribute_Round => Round :
5827 -- First we get the (exact result) in units of small
5829 Sr := Expr_Value_R (E1) / Small_Value (C_Type);
5831 -- Now round that exactly to an integer
5833 Si := UR_To_Uint (Sr);
5835 -- Finally the result is obtained by converting back to real
5837 Fold_Ureal (N, Si * Small_Value (C_Type), Static);
5844 when Attribute_Rounding =>
5846 Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
5852 when Attribute_Safe_Emax =>
5853 Float_Attribute_Universal_Integer (
5867 when Attribute_Safe_First =>
5868 Float_Attribute_Universal_Real (
5869 IEEES_Safe_First'Universal_Literal_String,
5870 IEEEL_Safe_First'Universal_Literal_String,
5871 IEEEX_Safe_First'Universal_Literal_String,
5872 VAXFF_Safe_First'Universal_Literal_String,
5873 VAXDF_Safe_First'Universal_Literal_String,
5874 VAXGF_Safe_First'Universal_Literal_String,
5875 AAMPS_Safe_First'Universal_Literal_String,
5876 AAMPL_Safe_First'Universal_Literal_String);
5882 when Attribute_Safe_Large =>
5883 if Is_Fixed_Point_Type (P_Type) then
5885 (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
5887 Float_Attribute_Universal_Real (
5888 IEEES_Safe_Large'Universal_Literal_String,
5889 IEEEL_Safe_Large'Universal_Literal_String,
5890 IEEEX_Safe_Large'Universal_Literal_String,
5891 VAXFF_Safe_Large'Universal_Literal_String,
5892 VAXDF_Safe_Large'Universal_Literal_String,
5893 VAXGF_Safe_Large'Universal_Literal_String,
5894 AAMPS_Safe_Large'Universal_Literal_String,
5895 AAMPL_Safe_Large'Universal_Literal_String);
5902 when Attribute_Safe_Last =>
5903 Float_Attribute_Universal_Real (
5904 IEEES_Safe_Last'Universal_Literal_String,
5905 IEEEL_Safe_Last'Universal_Literal_String,
5906 IEEEX_Safe_Last'Universal_Literal_String,
5907 VAXFF_Safe_Last'Universal_Literal_String,
5908 VAXDF_Safe_Last'Universal_Literal_String,
5909 VAXGF_Safe_Last'Universal_Literal_String,
5910 AAMPS_Safe_Last'Universal_Literal_String,
5911 AAMPL_Safe_Last'Universal_Literal_String);
5917 when Attribute_Safe_Small =>
5919 -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant
5920 -- for fixed-point, since is the same as Small, but we implement
5921 -- it for backwards compatibility.
5923 if Is_Fixed_Point_Type (P_Type) then
5924 Fold_Ureal (N, Small_Value (P_Type), Static);
5926 -- Ada 83 Safe_Small for floating-point cases
5929 Float_Attribute_Universal_Real (
5930 IEEES_Safe_Small'Universal_Literal_String,
5931 IEEEL_Safe_Small'Universal_Literal_String,
5932 IEEEX_Safe_Small'Universal_Literal_String,
5933 VAXFF_Safe_Small'Universal_Literal_String,
5934 VAXDF_Safe_Small'Universal_Literal_String,
5935 VAXGF_Safe_Small'Universal_Literal_String,
5936 AAMPS_Safe_Small'Universal_Literal_String,
5937 AAMPL_Safe_Small'Universal_Literal_String);
5944 when Attribute_Scale =>
5945 Fold_Uint (N, Scale_Value (P_Type), True);
5951 when Attribute_Scaling =>
5954 (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
5960 when Attribute_Signed_Zeros =>
5962 (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static);
5968 -- Size attribute returns the RM size. All scalar types can be folded,
5969 -- as well as any types for which the size is known by the front end,
5970 -- including any type for which a size attribute is specified.
5972 when Attribute_Size | Attribute_VADS_Size => Size : declare
5973 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
5976 if RM_Size (P_TypeA) /= Uint_0 then
5980 if Id = Attribute_VADS_Size or else Use_VADS_Size then
5982 S : constant Node_Id := Size_Clause (P_TypeA);
5985 -- If a size clause applies, then use the size from it.
5986 -- This is one of the rare cases where we can use the
5987 -- Size_Clause field for a subtype when Has_Size_Clause
5988 -- is False. Consider:
5990 -- type x is range 1 .. 64;
5991 -- for x'size use 12;
5992 -- subtype y is x range 0 .. 3;
5994 -- Here y has a size clause inherited from x, but normally
5995 -- it does not apply, and y'size is 2. However, y'VADS_Size
5996 -- is indeed 12 and not 2.
5999 and then Is_OK_Static_Expression (Expression (S))
6001 Fold_Uint (N, Expr_Value (Expression (S)), True);
6003 -- If no size is specified, then we simply use the object
6004 -- size in the VADS_Size case (e.g. Natural'Size is equal
6005 -- to Integer'Size, not one less).
6008 Fold_Uint (N, Esize (P_TypeA), True);
6012 -- Normal case (Size) in which case we want the RM_Size
6017 Static and then Is_Discrete_Type (P_TypeA));
6026 when Attribute_Small =>
6028 -- The floating-point case is present only for Ada 83 compatability.
6029 -- Note that strictly this is an illegal addition, since we are
6030 -- extending an Ada 95 defined attribute, but we anticipate an
6031 -- ARG ruling that will permit this.
6033 if Is_Floating_Point_Type (P_Type) then
6035 -- Ada 83 attribute is defined as (RM83 3.5.8)
6037 -- T'Small = 2.0**(-T'Emax - 1)
6041 -- T'Emax = 4 * T'Mantissa
6043 Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
6045 -- Normal Ada 95 fixed-point case
6048 Fold_Ureal (N, Small_Value (P_Type), True);
6055 when Attribute_Stream_Size =>
6062 when Attribute_Succ => Succ :
6064 -- Floating-point case
6066 if Is_Floating_Point_Type (P_Type) then
6068 Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)), Static);
6072 elsif Is_Fixed_Point_Type (P_Type) then
6074 Expr_Value_R (E1) + Small_Value (P_Type), Static);
6076 -- Modular integer case (wraps)
6078 elsif Is_Modular_Integer_Type (P_Type) then
6079 Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
6081 -- Other scalar cases
6084 pragma Assert (Is_Scalar_Type (P_Type));
6086 if Is_Enumeration_Type (P_Type)
6087 and then Expr_Value (E1) =
6088 Expr_Value (Type_High_Bound (P_Base_Type))
6090 Apply_Compile_Time_Constraint_Error
6091 (N, "Succ of `&''Last`",
6092 CE_Overflow_Check_Failed,
6094 Warn => not Static);
6099 Fold_Uint (N, Expr_Value (E1) + 1, Static);
6108 when Attribute_Truncation =>
6110 Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)), Static);
6116 when Attribute_Type_Class => Type_Class : declare
6117 Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
6121 if Is_Descendent_Of_Address (Typ) then
6122 Id := RE_Type_Class_Address;
6124 elsif Is_Enumeration_Type (Typ) then
6125 Id := RE_Type_Class_Enumeration;
6127 elsif Is_Integer_Type (Typ) then
6128 Id := RE_Type_Class_Integer;
6130 elsif Is_Fixed_Point_Type (Typ) then
6131 Id := RE_Type_Class_Fixed_Point;
6133 elsif Is_Floating_Point_Type (Typ) then
6134 Id := RE_Type_Class_Floating_Point;
6136 elsif Is_Array_Type (Typ) then
6137 Id := RE_Type_Class_Array;
6139 elsif Is_Record_Type (Typ) then
6140 Id := RE_Type_Class_Record;
6142 elsif Is_Access_Type (Typ) then
6143 Id := RE_Type_Class_Access;
6145 elsif Is_Enumeration_Type (Typ) then
6146 Id := RE_Type_Class_Enumeration;
6148 elsif Is_Task_Type (Typ) then
6149 Id := RE_Type_Class_Task;
6151 -- We treat protected types like task types. It would make more
6152 -- sense to have another enumeration value, but after all the
6153 -- whole point of this feature is to be exactly DEC compatible,
6154 -- and changing the type Type_Clas would not meet this requirement.
6156 elsif Is_Protected_Type (Typ) then
6157 Id := RE_Type_Class_Task;
6159 -- Not clear if there are any other possibilities, but if there
6160 -- are, then we will treat them as the address case.
6163 Id := RE_Type_Class_Address;
6166 Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
6170 -----------------------
6171 -- Unbiased_Rounding --
6172 -----------------------
6174 when Attribute_Unbiased_Rounding =>
6176 Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)),
6179 -------------------------
6180 -- Unconstrained_Array --
6181 -------------------------
6183 when Attribute_Unconstrained_Array => Unconstrained_Array : declare
6184 Typ : constant Entity_Id := Underlying_Type (P_Type);
6187 Rewrite (N, New_Occurrence_Of (
6189 Is_Array_Type (P_Type)
6190 and then not Is_Constrained (Typ)), Loc));
6192 -- Analyze and resolve as boolean, note that this attribute is
6193 -- a static attribute in GNAT.
6195 Analyze_And_Resolve (N, Standard_Boolean);
6197 end Unconstrained_Array;
6203 -- Processing is shared with Size
6209 when Attribute_Val => Val :
6211 if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
6213 Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
6215 Apply_Compile_Time_Constraint_Error
6216 (N, "Val expression out of range",
6217 CE_Range_Check_Failed,
6218 Warn => not Static);
6224 Fold_Uint (N, Expr_Value (E1), Static);
6232 -- The Value_Size attribute for a type returns the RM size of the
6233 -- type. This an always be folded for scalar types, and can also
6234 -- be folded for non-scalar types if the size is set.
6236 when Attribute_Value_Size => Value_Size : declare
6237 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
6240 if RM_Size (P_TypeA) /= Uint_0 then
6241 Fold_Uint (N, RM_Size (P_TypeA), True);
6250 -- Version can never be static
6252 when Attribute_Version =>
6259 -- Wide_Image is a scalar attribute, but is never static, because it
6260 -- is not a static function (having a non-scalar argument (RM 4.9(22))
6262 when Attribute_Wide_Image =>
6265 ---------------------
6266 -- Wide_Wide_Image --
6267 ---------------------
6269 -- Wide_Wide_Image is a scalar attribute but is never static, because it
6270 -- is not a static function (having a non-scalar argument (RM 4.9(22)).
6272 when Attribute_Wide_Wide_Image =>
6275 ---------------------
6276 -- Wide_Wide_Width --
6277 ---------------------
6279 -- Processing for Wide_Wide_Width is combined with Width
6285 -- Processing for Wide_Width is combined with Width
6291 -- This processing also handles the case of Wide_[Wide_]Width
6293 when Attribute_Width |
6294 Attribute_Wide_Width |
6295 Attribute_Wide_Wide_Width => Width :
6297 if Compile_Time_Known_Bounds (P_Type) then
6299 -- Floating-point types
6301 if Is_Floating_Point_Type (P_Type) then
6303 -- Width is zero for a null range (RM 3.5 (38))
6305 if Expr_Value_R (Type_High_Bound (P_Type)) <
6306 Expr_Value_R (Type_Low_Bound (P_Type))
6308 Fold_Uint (N, Uint_0, True);
6311 -- For floating-point, we have +N.dddE+nnn where length
6312 -- of ddd is determined by type'Digits - 1, but is one
6313 -- if Digits is one (RM 3.5 (33)).
6315 -- nnn is set to 2 for Short_Float and Float (32 bit
6316 -- floats), and 3 for Long_Float and Long_Long_Float.
6317 -- This is not quite right, but is good enough.
6321 Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
6324 if Esize (P_Type) <= 32 then
6330 Fold_Uint (N, UI_From_Int (Len), True);
6334 -- Fixed-point types
6336 elsif Is_Fixed_Point_Type (P_Type) then
6338 -- Width is zero for a null range (RM 3.5 (38))
6340 if Expr_Value (Type_High_Bound (P_Type)) <
6341 Expr_Value (Type_Low_Bound (P_Type))
6343 Fold_Uint (N, Uint_0, True);
6345 -- The non-null case depends on the specific real type
6348 -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
6351 (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True);
6358 R : constant Entity_Id := Root_Type (P_Type);
6359 Lo : constant Uint :=
6360 Expr_Value (Type_Low_Bound (P_Type));
6361 Hi : constant Uint :=
6362 Expr_Value (Type_High_Bound (P_Type));
6375 -- Width for types derived from Standard.Character
6376 -- and Standard.Wide_[Wide_]Character.
6378 elsif R = Standard_Character
6379 or else R = Standard_Wide_Character
6380 or else R = Standard_Wide_Wide_Character
6384 -- Set W larger if needed
6386 for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
6388 -- All wide characters look like Hex_hhhhhhhh
6394 C := Character'Val (J);
6396 -- Test for all cases where Character'Image
6397 -- yields an image that is longer than three
6398 -- characters. First the cases of Reserved_xxx
6399 -- names (length = 12).
6402 when Reserved_128 | Reserved_129 |
6403 Reserved_132 | Reserved_153
6407 when BS | HT | LF | VT | FF | CR |
6408 SO | SI | EM | FS | GS | RS |
6409 US | RI | MW | ST | PM
6413 when NUL | SOH | STX | ETX | EOT |
6414 ENQ | ACK | BEL | DLE | DC1 |
6415 DC2 | DC3 | DC4 | NAK | SYN |
6416 ETB | CAN | SUB | ESC | DEL |
6417 BPH | NBH | NEL | SSA | ESA |
6418 HTS | HTJ | VTS | PLD | PLU |
6419 SS2 | SS3 | DCS | PU1 | PU2 |
6420 STS | CCH | SPA | EPA | SOS |
6421 SCI | CSI | OSC | APC
6425 when Space .. Tilde |
6426 No_Break_Space .. LC_Y_Diaeresis
6431 W := Int'Max (W, Wt);
6435 -- Width for types derived from Standard.Boolean
6437 elsif R = Standard_Boolean then
6444 -- Width for integer types
6446 elsif Is_Integer_Type (P_Type) then
6447 T := UI_Max (abs Lo, abs Hi);
6455 -- Only remaining possibility is user declared enum type
6458 pragma Assert (Is_Enumeration_Type (P_Type));
6461 L := First_Literal (P_Type);
6463 while Present (L) loop
6465 -- Only pay attention to in range characters
6467 if Lo <= Enumeration_Pos (L)
6468 and then Enumeration_Pos (L) <= Hi
6470 -- For Width case, use decoded name
6472 if Id = Attribute_Width then
6473 Get_Decoded_Name_String (Chars (L));
6474 Wt := Nat (Name_Len);
6476 -- For Wide_[Wide_]Width, use encoded name, and
6477 -- then adjust for the encoding.
6480 Get_Name_String (Chars (L));
6482 -- Character literals are always of length 3
6484 if Name_Buffer (1) = 'Q' then
6487 -- Otherwise loop to adjust for upper/wide chars
6490 Wt := Nat (Name_Len);
6492 for J in 1 .. Name_Len loop
6493 if Name_Buffer (J) = 'U' then
6495 elsif Name_Buffer (J) = 'W' then
6502 W := Int'Max (W, Wt);
6509 Fold_Uint (N, UI_From_Int (W), True);
6515 -- The following attributes can never be folded, and furthermore we
6516 -- should not even have entered the case statement for any of these.
6517 -- Note that in some cases, the values have already been folded as
6518 -- a result of the processing in Analyze_Attribute.
6520 when Attribute_Abort_Signal |
6523 Attribute_Address_Size |
6524 Attribute_Asm_Input |
6525 Attribute_Asm_Output |
6527 Attribute_Bit_Order |
6528 Attribute_Bit_Position |
6529 Attribute_Callable |
6532 Attribute_Code_Address |
6534 Attribute_Default_Bit_Order |
6535 Attribute_Elaborated |
6536 Attribute_Elab_Body |
6537 Attribute_Elab_Spec |
6538 Attribute_External_Tag |
6539 Attribute_First_Bit |
6541 Attribute_Last_Bit |
6542 Attribute_Maximum_Alignment |
6544 Attribute_Partition_ID |
6545 Attribute_Pool_Address |
6546 Attribute_Position |
6548 Attribute_Storage_Pool |
6549 Attribute_Storage_Size |
6550 Attribute_Storage_Unit |
6552 Attribute_Target_Name |
6553 Attribute_Terminated |
6554 Attribute_To_Address |
6555 Attribute_UET_Address |
6556 Attribute_Unchecked_Access |
6557 Attribute_Universal_Literal_String |
6558 Attribute_Unrestricted_Access |
6561 Attribute_Wchar_T_Size |
6562 Attribute_Wide_Value |
6563 Attribute_Wide_Wide_Value |
6564 Attribute_Word_Size |
6567 raise Program_Error;
6570 -- At the end of the case, one more check. If we did a static evaluation
6571 -- so that the result is now a literal, then set Is_Static_Expression
6572 -- in the constant only if the prefix type is a static subtype. For
6573 -- non-static subtypes, the folding is still OK, but not static.
6575 -- An exception is the GNAT attribute Constrained_Array which is
6576 -- defined to be a static attribute in all cases.
6578 if Nkind (N) = N_Integer_Literal
6579 or else Nkind (N) = N_Real_Literal
6580 or else Nkind (N) = N_Character_Literal
6581 or else Nkind (N) = N_String_Literal
6582 or else (Is_Entity_Name (N)
6583 and then Ekind (Entity (N)) = E_Enumeration_Literal)
6585 Set_Is_Static_Expression (N, Static);
6587 -- If this is still an attribute reference, then it has not been folded
6588 -- and that means that its expressions are in a non-static context.
6590 elsif Nkind (N) = N_Attribute_Reference then
6593 -- Note: the else case not covered here are odd cases where the
6594 -- processing has transformed the attribute into something other
6595 -- than a constant. Nothing more to do in such cases.
6603 ------------------------------
6604 -- Is_Anonymous_Tagged_Base --
6605 ------------------------------
6607 function Is_Anonymous_Tagged_Base
6614 Anon = Current_Scope
6615 and then Is_Itype (Anon)
6616 and then Associated_Node_For_Itype (Anon) = Parent (Typ);
6617 end Is_Anonymous_Tagged_Base;
6619 -----------------------
6620 -- Resolve_Attribute --
6621 -----------------------
6623 procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
6624 Loc : constant Source_Ptr := Sloc (N);
6625 P : constant Node_Id := Prefix (N);
6626 Aname : constant Name_Id := Attribute_Name (N);
6627 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
6628 Btyp : constant Entity_Id := Base_Type (Typ);
6629 Index : Interp_Index;
6631 Nom_Subt : Entity_Id;
6633 procedure Accessibility_Message;
6634 -- Error, or warning within an instance, if the static accessibility
6635 -- rules of 3.10.2 are violated.
6637 ---------------------------
6638 -- Accessibility_Message --
6639 ---------------------------
6641 procedure Accessibility_Message is
6642 Indic : Node_Id := Parent (Parent (N));
6645 -- In an instance, this is a runtime check, but one we
6646 -- know will fail, so generate an appropriate warning.
6648 if In_Instance_Body then
6650 ("?non-local pointer cannot point to local object", P);
6652 ("?Program_Error will be raised at run time", P);
6654 Make_Raise_Program_Error (Loc,
6655 Reason => PE_Accessibility_Check_Failed));
6661 ("non-local pointer cannot point to local object", P);
6663 -- Check for case where we have a missing access definition
6665 if Is_Record_Type (Current_Scope)
6667 (Nkind (Parent (N)) = N_Discriminant_Association
6669 Nkind (Parent (N)) = N_Index_Or_Discriminant_Constraint)
6671 Indic := Parent (Parent (N));
6672 while Present (Indic)
6673 and then Nkind (Indic) /= N_Subtype_Indication
6675 Indic := Parent (Indic);
6678 if Present (Indic) then
6680 ("\use an access definition for" &
6681 " the access discriminant of&", N,
6682 Entity (Subtype_Mark (Indic)));
6686 end Accessibility_Message;
6688 -- Start of processing for Resolve_Attribute
6691 -- If error during analysis, no point in continuing, except for
6692 -- array types, where we get better recovery by using unconstrained
6693 -- indices than nothing at all (see Check_Array_Type).
6696 and then Attr_Id /= Attribute_First
6697 and then Attr_Id /= Attribute_Last
6698 and then Attr_Id /= Attribute_Length
6699 and then Attr_Id /= Attribute_Range
6704 -- If attribute was universal type, reset to actual type
6706 if Etype (N) = Universal_Integer
6707 or else Etype (N) = Universal_Real
6712 -- Remaining processing depends on attribute
6720 -- For access attributes, if the prefix denotes an entity, it is
6721 -- interpreted as a name, never as a call. It may be overloaded,
6722 -- in which case resolution uses the profile of the context type.
6723 -- Otherwise prefix must be resolved.
6725 when Attribute_Access
6726 | Attribute_Unchecked_Access
6727 | Attribute_Unrestricted_Access =>
6729 if Is_Variable (P) then
6730 Note_Possible_Modification (P);
6733 if Is_Entity_Name (P) then
6734 if Is_Overloaded (P) then
6735 Get_First_Interp (P, Index, It);
6737 while Present (It.Nam) loop
6739 if Type_Conformant (Designated_Type (Typ), It.Nam) then
6740 Set_Entity (P, It.Nam);
6742 -- The prefix is definitely NOT overloaded anymore
6743 -- at this point, so we reset the Is_Overloaded
6744 -- flag to avoid any confusion when reanalyzing
6747 Set_Is_Overloaded (P, False);
6748 Generate_Reference (Entity (P), P);
6752 Get_Next_Interp (Index, It);
6755 -- If it is a subprogram name or a type, there is nothing
6758 elsif not Is_Overloadable (Entity (P))
6759 and then not Is_Type (Entity (P))
6764 Error_Msg_Name_1 := Aname;
6766 if not Is_Entity_Name (P) then
6769 elsif Is_Abstract (Entity (P))
6770 and then Is_Overloadable (Entity (P))
6772 Error_Msg_N ("prefix of % attribute cannot be abstract", P);
6773 Set_Etype (N, Any_Type);
6775 elsif Convention (Entity (P)) = Convention_Intrinsic then
6776 if Ekind (Entity (P)) = E_Enumeration_Literal then
6778 ("prefix of % attribute cannot be enumeration literal",
6782 ("prefix of % attribute cannot be intrinsic", P);
6785 Set_Etype (N, Any_Type);
6787 elsif Is_Thread_Body (Entity (P)) then
6789 ("prefix of % attribute cannot be a thread body", P);
6792 -- Assignments, return statements, components of aggregates,
6793 -- generic instantiations will require convention checks if
6794 -- the type is an access to subprogram. Given that there will
6795 -- also be accessibility checks on those, this is where the
6796 -- checks can eventually be centralized ???
6798 if Ekind (Btyp) = E_Access_Subprogram_Type
6800 Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
6802 Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
6804 if Convention (Btyp) /= Convention (Entity (P)) then
6806 ("subprogram has invalid convention for context", P);
6809 Check_Subtype_Conformant
6810 (New_Id => Entity (P),
6811 Old_Id => Designated_Type (Btyp),
6815 if Attr_Id = Attribute_Unchecked_Access then
6816 Error_Msg_Name_1 := Aname;
6818 ("attribute% cannot be applied to a subprogram", P);
6820 elsif Aname = Name_Unrestricted_Access then
6821 null; -- Nothing to check
6823 -- Check the static accessibility rule of 3.10.2(32)
6824 -- In an instance body, if subprogram and type are both
6825 -- local, other rules prevent dangling references, and no
6826 -- warning is needed.
6828 elsif Attr_Id = Attribute_Access
6829 and then Subprogram_Access_Level (Entity (P)) >
6830 Type_Access_Level (Btyp)
6831 and then Ekind (Btyp) /=
6832 E_Anonymous_Access_Subprogram_Type
6833 and then Ekind (Btyp) /=
6834 E_Anonymous_Access_Protected_Subprogram_Type
6836 if not In_Instance_Body then
6838 ("subprogram must not be deeper than access type",
6841 elsif Scope (Entity (P)) /= Scope (Btyp) then
6843 ("subprogram must not be deeper than access type?",
6846 ("Constraint_Error will be raised ?", P);
6847 Set_Raises_Constraint_Error (N);
6850 -- Check the restriction of 3.10.2(32) that disallows
6851 -- the type of the access attribute to be declared
6852 -- outside a generic body when the subprogram is declared
6853 -- within that generic body.
6855 -- Ada2005: If the expected type is for an access
6856 -- parameter, this clause does not apply.
6858 elsif Present (Enclosing_Generic_Body (Entity (P)))
6859 and then Enclosing_Generic_Body (Entity (P)) /=
6860 Enclosing_Generic_Body (Btyp)
6862 Ekind (Btyp) /= E_Anonymous_Access_Subprogram_Type
6865 ("access type must not be outside generic body", P);
6869 -- If this is a renaming, an inherited operation, or a
6870 -- subprogram instance, use the original entity.
6872 if Is_Entity_Name (P)
6873 and then Is_Overloadable (Entity (P))
6874 and then Present (Alias (Entity (P)))
6877 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
6880 elsif Nkind (P) = N_Selected_Component
6881 and then Is_Overloadable (Entity (Selector_Name (P)))
6883 -- Protected operation. If operation is overloaded, must
6884 -- disambiguate. Prefix that denotes protected object itself
6885 -- is resolved with its own type.
6887 if Attr_Id = Attribute_Unchecked_Access then
6888 Error_Msg_Name_1 := Aname;
6890 ("attribute% cannot be applied to protected operation", P);
6893 Resolve (Prefix (P));
6894 Generate_Reference (Entity (Selector_Name (P)), P);
6896 elsif Is_Overloaded (P) then
6898 -- Use the designated type of the context to disambiguate
6899 -- Note that this was not strictly conformant to Ada 95,
6900 -- but was the implementation adopted by most Ada 95 compilers.
6901 -- The use of the context type to resolve an Access attribute
6902 -- reference is now mandated in AI-235 for Ada 2005.
6905 Index : Interp_Index;
6909 Get_First_Interp (P, Index, It);
6910 while Present (It.Typ) loop
6911 if Covers (Designated_Type (Typ), It.Typ) then
6912 Resolve (P, It.Typ);
6916 Get_Next_Interp (Index, It);
6923 -- X'Access is illegal if X denotes a constant and the access
6924 -- type is access-to-variable. Same for 'Unchecked_Access.
6925 -- The rule does not apply to 'Unrestricted_Access.
6927 if not (Ekind (Btyp) = E_Access_Subprogram_Type
6928 or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
6929 or else (Is_Record_Type (Btyp) and then
6930 Present (Corresponding_Remote_Type (Btyp)))
6931 or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
6932 or else Ekind (Btyp)
6933 = E_Anonymous_Access_Protected_Subprogram_Type
6934 or else Is_Access_Constant (Btyp)
6935 or else Is_Variable (P)
6936 or else Attr_Id = Attribute_Unrestricted_Access)
6938 if Comes_From_Source (N) then
6939 Error_Msg_N ("access-to-variable designates constant", P);
6943 if (Attr_Id = Attribute_Access
6945 Attr_Id = Attribute_Unchecked_Access)
6946 and then (Ekind (Btyp) = E_General_Access_Type
6947 or else Ekind (Btyp) = E_Anonymous_Access_Type)
6949 -- Ada 2005 (AI-230): Check the accessibility of anonymous
6950 -- access types in record and array components. For a
6951 -- component definition the level is the same of the
6952 -- enclosing composite type.
6954 if Ada_Version >= Ada_05
6955 and then Is_Local_Anonymous_Access (Btyp)
6956 and then Object_Access_Level (P) > Type_Access_Level (Btyp)
6958 -- In an instance, this is a runtime check, but one we
6959 -- know will fail, so generate an appropriate warning.
6961 if In_Instance_Body then
6963 ("?non-local pointer cannot point to local object", P);
6965 ("?Program_Error will be raised at run time", P);
6967 Make_Raise_Program_Error (Loc,
6968 Reason => PE_Accessibility_Check_Failed));
6972 ("non-local pointer cannot point to local object", P);
6976 if Is_Dependent_Component_Of_Mutable_Object (P) then
6978 ("illegal attribute for discriminant-dependent component",
6982 -- Check the static matching rule of 3.10.2(27). The
6983 -- nominal subtype of the prefix must statically
6984 -- match the designated type.
6986 Nom_Subt := Etype (P);
6988 if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
6989 Nom_Subt := Etype (Nom_Subt);
6992 if Is_Tagged_Type (Designated_Type (Typ)) then
6994 -- If the attribute is in the context of an access
6995 -- parameter, then the prefix is allowed to be of
6996 -- the class-wide type (by AI-127).
6998 if Ekind (Typ) = E_Anonymous_Access_Type then
6999 if not Covers (Designated_Type (Typ), Nom_Subt)
7000 and then not Covers (Nom_Subt, Designated_Type (Typ))
7006 Desig := Designated_Type (Typ);
7008 if Is_Class_Wide_Type (Desig) then
7009 Desig := Etype (Desig);
7012 if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then
7017 ("type of prefix: & not compatible",
7020 ("\with &, the expected designated type",
7021 P, Designated_Type (Typ));
7026 elsif not Covers (Designated_Type (Typ), Nom_Subt)
7028 (not Is_Class_Wide_Type (Designated_Type (Typ))
7029 and then Is_Class_Wide_Type (Nom_Subt))
7032 ("type of prefix: & is not covered", P, Nom_Subt);
7034 ("\by &, the expected designated type" &
7035 " ('R'M 3.10.2 (27))", P, Designated_Type (Typ));
7038 if Is_Class_Wide_Type (Designated_Type (Typ))
7039 and then Has_Discriminants (Etype (Designated_Type (Typ)))
7040 and then Is_Constrained (Etype (Designated_Type (Typ)))
7041 and then Designated_Type (Typ) /= Nom_Subt
7043 Apply_Discriminant_Check
7044 (N, Etype (Designated_Type (Typ)));
7047 elsif not Subtypes_Statically_Match
7048 (Designated_Type (Base_Type (Typ)), Nom_Subt)
7050 not (Has_Discriminants (Designated_Type (Typ))
7053 (Designated_Type (Base_Type (Typ))))
7056 ("object subtype must statically match "
7057 & "designated subtype", P);
7059 if Is_Entity_Name (P)
7060 and then Is_Array_Type (Designated_Type (Typ))
7064 D : constant Node_Id := Declaration_Node (Entity (P));
7067 Error_Msg_N ("aliased object has explicit bounds?",
7069 Error_Msg_N ("\declare without bounds"
7070 & " (and with explicit initialization)?", D);
7071 Error_Msg_N ("\for use with unconstrained access?", D);
7076 -- Check the static accessibility rule of 3.10.2(28).
7077 -- Note that this check is not performed for the
7078 -- case of an anonymous access type, since the access
7079 -- attribute is always legal in such a context.
7081 if Attr_Id /= Attribute_Unchecked_Access
7082 and then Object_Access_Level (P) > Type_Access_Level (Btyp)
7083 and then Ekind (Btyp) = E_General_Access_Type
7085 Accessibility_Message;
7090 if Ekind (Btyp) = E_Access_Protected_Subprogram_Type
7092 Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
7094 if Is_Entity_Name (P)
7095 and then not Is_Protected_Type (Scope (Entity (P)))
7097 Error_Msg_N ("context requires a protected subprogram", P);
7099 -- Check accessibility of protected object against that
7100 -- of the access type, but only on user code, because
7101 -- the expander creates access references for handlers.
7102 -- If the context is an anonymous_access_to_protected,
7103 -- there are no accessibility checks either.
7105 elsif Object_Access_Level (P) > Type_Access_Level (Btyp)
7106 and then Comes_From_Source (N)
7107 and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
7108 and then No (Original_Access_Type (Typ))
7110 Accessibility_Message;
7114 elsif (Ekind (Btyp) = E_Access_Subprogram_Type
7116 Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type)
7117 and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
7119 Error_Msg_N ("context requires a non-protected subprogram", P);
7122 -- The context cannot be a pool-specific type, but this is a
7123 -- legality rule, not a resolution rule, so it must be checked
7124 -- separately, after possibly disambiguation (see AI-245).
7126 if Ekind (Btyp) = E_Access_Type
7127 and then Attr_Id /= Attribute_Unrestricted_Access
7129 Wrong_Type (N, Typ);
7134 -- Check for incorrect atomic/volatile reference (RM C.6(12))
7136 if Attr_Id /= Attribute_Unrestricted_Access then
7137 if Is_Atomic_Object (P)
7138 and then not Is_Atomic (Designated_Type (Typ))
7141 ("access to atomic object cannot yield access-to-" &
7142 "non-atomic type", P);
7144 elsif Is_Volatile_Object (P)
7145 and then not Is_Volatile (Designated_Type (Typ))
7148 ("access to volatile object cannot yield access-to-" &
7149 "non-volatile type", P);
7157 -- Deal with resolving the type for Address attribute, overloading
7158 -- is not permitted here, since there is no context to resolve it.
7160 when Attribute_Address | Attribute_Code_Address =>
7162 -- To be safe, assume that if the address of a variable is taken,
7163 -- it may be modified via this address, so note modification.
7165 if Is_Variable (P) then
7166 Note_Possible_Modification (P);
7169 if Nkind (P) in N_Subexpr
7170 and then Is_Overloaded (P)
7172 Get_First_Interp (P, Index, It);
7173 Get_Next_Interp (Index, It);
7175 if Present (It.Nam) then
7176 Error_Msg_Name_1 := Aname;
7178 ("prefix of % attribute cannot be overloaded", N);
7183 if not Is_Entity_Name (P)
7184 or else not Is_Overloadable (Entity (P))
7186 if not Is_Task_Type (Etype (P))
7187 or else Nkind (P) = N_Explicit_Dereference
7193 -- If this is the name of a derived subprogram, or that of a
7194 -- generic actual, the address is that of the original entity.
7196 if Is_Entity_Name (P)
7197 and then Is_Overloadable (Entity (P))
7198 and then Present (Alias (Entity (P)))
7201 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
7208 -- Prefix of the AST_Entry attribute is an entry name which must
7209 -- not be resolved, since this is definitely not an entry call.
7211 when Attribute_AST_Entry =>
7218 -- Prefix of Body_Version attribute can be a subprogram name which
7219 -- must not be resolved, since this is not a call.
7221 when Attribute_Body_Version =>
7228 -- Prefix of Caller attribute is an entry name which must not
7229 -- be resolved, since this is definitely not an entry call.
7231 when Attribute_Caller =>
7238 -- Shares processing with Address attribute
7244 -- If the prefix of the Count attribute is an entry name it must not
7245 -- be resolved, since this is definitely not an entry call. However,
7246 -- if it is an element of an entry family, the index itself may
7247 -- have to be resolved because it can be a general expression.
7249 when Attribute_Count =>
7250 if Nkind (P) = N_Indexed_Component
7251 and then Is_Entity_Name (Prefix (P))
7254 Indx : constant Node_Id := First (Expressions (P));
7255 Fam : constant Entity_Id := Entity (Prefix (P));
7257 Resolve (Indx, Entry_Index_Type (Fam));
7258 Apply_Range_Check (Indx, Entry_Index_Type (Fam));
7266 -- Prefix of the Elaborated attribute is a subprogram name which
7267 -- must not be resolved, since this is definitely not a call. Note
7268 -- that it is a library unit, so it cannot be overloaded here.
7270 when Attribute_Elaborated =>
7273 --------------------
7274 -- Mechanism_Code --
7275 --------------------
7277 -- Prefix of the Mechanism_Code attribute is a function name
7278 -- which must not be resolved. Should we check for overloaded ???
7280 when Attribute_Mechanism_Code =>
7287 -- Most processing is done in sem_dist, after determining the
7288 -- context type. Node is rewritten as a conversion to a runtime call.
7290 when Attribute_Partition_ID =>
7291 Process_Partition_Id (N);
7294 when Attribute_Pool_Address =>
7301 -- We replace the Range attribute node with a range expression
7302 -- whose bounds are the 'First and 'Last attributes applied to the
7303 -- same prefix. The reason that we do this transformation here
7304 -- instead of in the expander is that it simplifies other parts of
7305 -- the semantic analysis which assume that the Range has been
7306 -- replaced; thus it must be done even when in semantic-only mode
7307 -- (note that the RM specifically mentions this equivalence, we
7308 -- take care that the prefix is only evaluated once).
7310 when Attribute_Range => Range_Attribute :
7315 function Check_Discriminated_Prival
7318 -- The range of a private component constrained by a
7319 -- discriminant is rewritten to make the discriminant
7320 -- explicit. This solves some complex visibility problems
7321 -- related to the use of privals.
7323 --------------------------------
7324 -- Check_Discriminated_Prival --
7325 --------------------------------
7327 function Check_Discriminated_Prival
7332 if Is_Entity_Name (N)
7333 and then Ekind (Entity (N)) = E_In_Parameter
7334 and then not Within_Init_Proc
7336 return Make_Identifier (Sloc (N), Chars (Entity (N)));
7338 return Duplicate_Subexpr (N);
7340 end Check_Discriminated_Prival;
7342 -- Start of processing for Range_Attribute
7345 if not Is_Entity_Name (P)
7346 or else not Is_Type (Entity (P))
7351 -- Check whether prefix is (renaming of) private component
7352 -- of protected type.
7354 if Is_Entity_Name (P)
7355 and then Comes_From_Source (N)
7356 and then Is_Array_Type (Etype (P))
7357 and then Number_Dimensions (Etype (P)) = 1
7358 and then (Ekind (Scope (Entity (P))) = E_Protected_Type
7360 Ekind (Scope (Scope (Entity (P)))) =
7364 Check_Discriminated_Prival
7365 (Type_Low_Bound (Etype (First_Index (Etype (P)))));
7368 Check_Discriminated_Prival
7369 (Type_High_Bound (Etype (First_Index (Etype (P)))));
7373 Make_Attribute_Reference (Loc,
7374 Prefix => Duplicate_Subexpr (P),
7375 Attribute_Name => Name_Last,
7376 Expressions => Expressions (N));
7379 Make_Attribute_Reference (Loc,
7381 Attribute_Name => Name_First,
7382 Expressions => Expressions (N));
7385 -- If the original was marked as Must_Not_Freeze (see code
7386 -- in Sem_Ch3.Make_Index), then make sure the rewriting
7387 -- does not freeze either.
7389 if Must_Not_Freeze (N) then
7390 Set_Must_Not_Freeze (HB);
7391 Set_Must_Not_Freeze (LB);
7392 Set_Must_Not_Freeze (Prefix (HB));
7393 Set_Must_Not_Freeze (Prefix (LB));
7396 if Raises_Constraint_Error (Prefix (N)) then
7398 -- Preserve Sloc of prefix in the new bounds, so that
7399 -- the posted warning can be removed if we are within
7400 -- unreachable code.
7402 Set_Sloc (LB, Sloc (Prefix (N)));
7403 Set_Sloc (HB, Sloc (Prefix (N)));
7406 Rewrite (N, Make_Range (Loc, LB, HB));
7407 Analyze_And_Resolve (N, Typ);
7409 -- Normally after resolving attribute nodes, Eval_Attribute
7410 -- is called to do any possible static evaluation of the node.
7411 -- However, here since the Range attribute has just been
7412 -- transformed into a range expression it is no longer an
7413 -- attribute node and therefore the call needs to be avoided
7414 -- and is accomplished by simply returning from the procedure.
7417 end Range_Attribute;
7423 -- Prefix must not be resolved in this case, since it is not a
7424 -- real entity reference. No action of any kind is require!
7426 when Attribute_UET_Address =>
7429 ----------------------
7430 -- Unchecked_Access --
7431 ----------------------
7433 -- Processing is shared with Access
7435 -------------------------
7436 -- Unrestricted_Access --
7437 -------------------------
7439 -- Processing is shared with Access
7445 -- Apply range check. Note that we did not do this during the
7446 -- analysis phase, since we wanted Eval_Attribute to have a
7447 -- chance at finding an illegal out of range value.
7449 when Attribute_Val =>
7451 -- Note that we do our own Eval_Attribute call here rather than
7452 -- use the common one, because we need to do processing after
7453 -- the call, as per above comment.
7457 -- Eval_Attribute may replace the node with a raise CE, or
7458 -- fold it to a constant. Obviously we only apply a scalar
7459 -- range check if this did not happen!
7461 if Nkind (N) = N_Attribute_Reference
7462 and then Attribute_Name (N) = Name_Val
7464 Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
7473 -- Prefix of Version attribute can be a subprogram name which
7474 -- must not be resolved, since this is not a call.
7476 when Attribute_Version =>
7479 ----------------------
7480 -- Other Attributes --
7481 ----------------------
7483 -- For other attributes, resolve prefix unless it is a type. If
7484 -- the attribute reference itself is a type name ('Base and 'Class)
7485 -- then this is only legal within a task or protected record.
7488 if not Is_Entity_Name (P)
7489 or else not Is_Type (Entity (P))
7494 -- If the attribute reference itself is a type name ('Base,
7495 -- 'Class) then this is only legal within a task or protected
7496 -- record. What is this all about ???
7498 if Is_Entity_Name (N)
7499 and then Is_Type (Entity (N))
7501 if Is_Concurrent_Type (Entity (N))
7502 and then In_Open_Scopes (Entity (P))
7507 ("invalid use of subtype name in expression or call", N);
7511 -- For attributes whose argument may be a string, complete
7512 -- resolution of argument now. This avoids premature expansion
7513 -- (and the creation of transient scopes) before the attribute
7514 -- reference is resolved.
7517 when Attribute_Value =>
7518 Resolve (First (Expressions (N)), Standard_String);
7520 when Attribute_Wide_Value =>
7521 Resolve (First (Expressions (N)), Standard_Wide_String);
7523 when Attribute_Wide_Wide_Value =>
7524 Resolve (First (Expressions (N)), Standard_Wide_Wide_String);
7526 when others => null;
7530 -- Normally the Freezing is done by Resolve but sometimes the Prefix
7531 -- is not resolved, in which case the freezing must be done now.
7533 Freeze_Expression (P);
7535 -- Finally perform static evaluation on the attribute reference
7538 end Resolve_Attribute;
7540 --------------------------------
7541 -- Stream_Attribute_Available --
7542 --------------------------------
7544 function Stream_Attribute_Available
7546 Nam : TSS_Name_Type;
7547 Partial_View : Node_Id := Empty) return Boolean
7549 Etyp : Entity_Id := Typ;
7551 function Has_Specified_Stream_Attribute
7553 Nam : TSS_Name_Type) return Boolean;
7554 -- True iff there is a visible attribute definition clause specifying
7555 -- attribute Nam for Typ.
7557 ------------------------------------
7558 -- Has_Specified_Stream_Attribute --
7559 ------------------------------------
7561 function Has_Specified_Stream_Attribute
7563 Nam : TSS_Name_Type) return Boolean
7568 (Nam = TSS_Stream_Input
7569 and then Has_Specified_Stream_Input (Typ))
7571 (Nam = TSS_Stream_Output
7572 and then Has_Specified_Stream_Output (Typ))
7574 (Nam = TSS_Stream_Read
7575 and then Has_Specified_Stream_Read (Typ))
7577 (Nam = TSS_Stream_Write
7578 and then Has_Specified_Stream_Write (Typ));
7579 end Has_Specified_Stream_Attribute;
7581 -- Start of processing for Stream_Attribute_Available
7584 -- We need some comments in this body ???
7586 if Has_Specified_Stream_Attribute (Typ, Nam) then
7590 if Is_Class_Wide_Type (Typ) then
7591 return not Is_Limited_Type (Typ)
7592 or else Stream_Attribute_Available (Etype (Typ), Nam);
7595 if Nam = TSS_Stream_Input
7596 and then Is_Abstract (Typ)
7597 and then not Is_Class_Wide_Type (Typ)
7602 if not (Is_Limited_Type (Typ)
7603 or else (Present (Partial_View)
7604 and then Is_Limited_Type (Partial_View)))
7609 if Nam = TSS_Stream_Input then
7610 return Ada_Version >= Ada_05
7611 and then Stream_Attribute_Available (Etyp, TSS_Stream_Read);
7612 elsif Nam = TSS_Stream_Output then
7613 return Ada_Version >= Ada_05
7614 and then Stream_Attribute_Available (Etyp, TSS_Stream_Write);
7617 -- Case of Read and Write: check for attribute definition clause that
7618 -- applies to an ancestor type.
7620 while Etype (Etyp) /= Etyp loop
7621 Etyp := Etype (Etyp);
7623 if Has_Specified_Stream_Attribute (Etyp, Nam) then
7628 if Ada_Version < Ada_05 then
7630 -- In Ada 95 mode, also consider a non-visible definition
7633 Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
7636 and then Stream_Attribute_Available
7637 (Btyp, Nam, Partial_View => Typ);
7642 end Stream_Attribute_Available;