| blob | 1637863cf455bde79e3a0203a920a5fbee8f2dd5 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ A T T R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
10 -- --
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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 procedure Compile_Stream_Body_In_Scope
83 -- The body for a stream subprogram may be generated outside of the scope
84 -- of the type. If the type is fully private, it may depend on the full
85 -- view of other types (e.g. indices) that are currently private as well.
86 -- We install the declarations of the package in which the type is declared
87 -- before compiling the body in what is its proper environment. The Check
88 -- parameter indicates if checks are to be suppressed for the stream body.
89 -- We suppress checks for array/record reads, since the rule is that these
90 -- are like assignments, out of range values due to uninitialized storage,
91 -- or other invalid values do NOT cause a Constraint_Error to be raised.
93 procedure Expand_Access_To_Protected_Op
98 -- An attribute reference to a protected subprogram is transformed into
99 -- a pair of pointers: one to the object, and one to the operations.
100 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
102 procedure Expand_Fpt_Attribute
107 -- This procedure expands a call to a floating-point attribute function.
108 -- N is the attribute reference node, and Args is a list of arguments to
109 -- be passed to the function call. Pkg identifies the package containing
110 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
111 -- have already been converted to the floating-point type for which Pkg was
112 -- instantiated. The Nam argument is the relevant attribute processing
113 -- routine to be called. This is the same as the attribute name, except in
114 -- the Unaligned_Valid case.
117 -- This procedure expands a call to a floating-point attribute function
118 -- that takes a single floating-point argument. The function to be called
119 -- is always the same as the attribute name.
122 -- This procedure expands a call to a floating-point attribute function
123 -- that takes one floating-point argument and one integer argument. The
124 -- function to be called is always the same as the attribute name.
127 -- This procedure expands a call to a floating-point attribute function
128 -- that takes two floating-point arguments. The function to be called
129 -- is always the same as the attribute name.
132 -- Handles expansion of Pred or Succ attributes for case of non-real
133 -- operand with overflow checking required.
136 -- Used for Last, Last, and Length, when the prefix is an array type.
137 -- Obtains the corresponding index subtype.
139 procedure Find_Fat_Info
143 -- Given a floating-point type T, identifies the package containing the
144 -- attributes for this type (returned in Fat_Pkg), and the corresponding
145 -- type for which this package was instantiated from Fat_Gen. Error if T
146 -- is not a floating-point type.
148 function Find_Stream_Subprogram
151 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
152 -- types, the corresponding primitive operation is looked up, else the
153 -- appropriate TSS from the type itself, or from its closest ancestor
154 -- defining it, is returned. In both cases, inheritance of representation
155 -- aspects is thus taken into account.
158 -- Given a type, find a corresponding stream convert pragma that applies to
159 -- the implementation base type of this type (Typ). If found, return the
160 -- pragma node, otherwise return Empty if no pragma is found.
163 -- Utility for array attributes, returns true on packed constrained
164 -- arrays, and on access to same.
167 -- Returns true iff the given node refers to an attribute call that
168 -- can be expanded directly by the back end and does not need front end
169 -- expansion. Typically used for rounding and truncation attributes that
170 -- appear directly inside a conversion to integer.
172 ----------------------------------
173 -- Compile_Stream_Body_In_Scope --
174 ----------------------------------
176 procedure Compile_Stream_Body_In_Scope
181 is
186 begin
190 then
196 -- The entities in the package are now visible, but the generated
197 -- stream entity must appear in the current scope (usually an
198 -- enclosing stream function) so that itypes all have their proper
199 -- scopes.
206 else
212 -- Remove extra copy of current scope, and package itself
214 Pop_Scope;
219 -----------------------------------
220 -- Expand_Access_To_Protected_Op --
221 -----------------------------------
223 procedure Expand_Access_To_Protected_Op
227 is
228 -- The value of the attribute_reference is a record containing two
229 -- fields: an access to the protected object, and an access to the
230 -- subprogram itself. The prefix is a selected component.
243 -- If the 'Access is to a local operation, but appears in a context
244 -- where it may lead to a call from outside the object, we must treat
245 -- this as an external call. Clearly we cannot tell without full
246 -- flow analysis, and a subsequent call that uses this 'Access may
247 -- lead to a bounded error (trying to seize locks twice, e.g.). For
248 -- now we treat 'Access as a potential external call if it is an actual
249 -- in a call to an outside subprogram.
251 --------------------------
252 -- May_Be_External_Call --
253 --------------------------
259 begin
260 -- Account for the case where the Access attribute is part of a
261 -- named parameter association.
269 then
272 else
277 -- Start of processing for Expand_Access_To_Protected_Op
279 begin
280 -- Within the body of the protected type, the prefix
281 -- designates a local operation, and the object is the first
282 -- parameter of the corresponding protected body of the
283 -- current enclosing operation.
287 Sub :=
288 New_Occurrence_Of
290 else
291 Sub :=
292 New_Occurrence_Of
296 -- Don't traverse the scopes when the attribute occurs within an init
297 -- proc, because we directly use the _init formal of the init proc in
298 -- that case.
309 -- In case of protected entries the first formal of its Protected_
310 -- Body_Subprogram is the address of the object.
313 Obj_Ref :=
314 New_Occurrence_Of
315 (First_Formal
318 -- If the current scope is an init proc, then use the address of the
319 -- _init formal as the object reference.
322 Obj_Ref :=
327 -- In case of protected subprograms the first formal of its
328 -- Protected_Body_Subprogram is the object and we get its address.
330 else
331 Obj_Ref :=
333 Prefix =>
334 New_Occurrence_Of
335 (First_Formal
340 -- Case where the prefix is not an entity name. Find the
341 -- version of the protected operation to be called from
342 -- outside the protected object.
344 else
345 Sub :=
346 New_Occurrence_Of
347 (External_Subprogram
350 Obj_Ref :=
356 Agg :=
358 Expressions =>
359 New_List (
360 Obj_Ref,
370 -- For subsequent analysis, the node must retain its type.
371 -- The backend will replace it with the equivalent type where
372 -- needed.
377 --------------------------
378 -- Expand_Fpt_Attribute --
379 --------------------------
381 procedure Expand_Fpt_Attribute
386 is
391 begin
392 -- The function name is the selected component Attr_xxx.yyy where
393 -- Attr_xxx is the package name, and yyy is the argument Nam.
395 -- Note: it would be more usual to have separate RE entries for each
396 -- of the entities in the Fat packages, but first they have identical
397 -- names (so we would have to have lots of renaming declarations to
398 -- meet the normal RE rule of separate names for all runtime entities),
399 -- and second there would be an awful lot of them!
401 Fnm :=
406 -- The generated call is given the provided set of parameters, and then
407 -- wrapped in a conversion which converts the result to the target type
408 -- We use the base type as the target because a range check may be
409 -- required.
420 ----------------------------
421 -- Expand_Fpt_Attribute_R --
422 ----------------------------
424 -- The single argument is converted to its root type to call the
425 -- appropriate runtime function, with the actual call being built
426 -- by Expand_Fpt_Attribute
432 begin
434 Expand_Fpt_Attribute
439 -----------------------------
440 -- Expand_Fpt_Attribute_RI --
441 -----------------------------
443 -- The first argument is converted to its root type and the second
444 -- argument is converted to standard long long integer to call the
445 -- appropriate runtime function, with the actual call being built
446 -- by Expand_Fpt_Attribute
453 begin
455 Expand_Fpt_Attribute
457 New_List (
462 -----------------------------
463 -- Expand_Fpt_Attribute_RR --
464 -----------------------------
466 -- The two arguments are converted to their root types to call the
467 -- appropriate runtime function, with the actual call being built
468 -- by Expand_Fpt_Attribute
475 begin
477 Expand_Fpt_Attribute
479 New_List (
484 ----------------------------------
485 -- Expand_N_Attribute_Reference --
486 ----------------------------------
498 -- Rewrites a stream attribute for Read, Write or Output with the
499 -- procedure call. Pname is the entity for the procedure to call.
501 ------------------------------
502 -- Rewrite_Stream_Proc_Call --
503 ------------------------------
511 begin
512 -- The expansion depends on Item, the second actual, which is
513 -- the object being streamed in or out.
515 -- If the item is a component of a packed array type, and
516 -- a conversion is needed on exit, we introduce a temporary to
517 -- hold the value, because otherwise the packed reference will
518 -- not be properly expanded.
523 and then Is_Written
524 then
525 declare
527 Make_Defining_Identifier
532 begin
533 Decl :=
536 Object_Definition =>
540 Assn :=
543 Expression =>
544 Unchecked_Convert_To
549 New_List (
550 Decl,
554 Assn));
561 -- For the class-wide dispatching cases, and for cases in which
562 -- the base type of the second argument matches the base type of
563 -- the corresponding formal parameter (that is to say the stream
564 -- operation is not inherited), we are all set, and can use the
565 -- argument unchanged.
567 -- For all other cases we do an unchecked conversion of the second
568 -- parameter to the type of the formal of the procedure we are
569 -- calling. This deals with the private type cases, and with going
570 -- to the root type as required in elementary type case.
575 then
579 -- For untagged derived types set Assignment_OK, to prevent
580 -- copies from being created when the unchecked conversion
581 -- is expanded (which would happen in Remove_Side_Effects
582 -- if Expand_N_Unchecked_Conversion were allowed to call
583 -- Force_Evaluation). The copy could violate Ada semantics
584 -- in cases such as an actual that is an out parameter.
585 -- Note that this approach is also used in exp_ch7 for calls
586 -- to controlled type operations to prevent problems with
587 -- actuals wrapped in unchecked conversions.
594 -- And now rewrite the call
604 -- Start of processing for Expand_N_Attribute_Reference
606 begin
607 -- Do required validity checking, if enabled. Do not apply check to
608 -- output parameters of an Asm instruction, since the value of this
609 -- is not set till after the attribute has been elaborated.
613 then
614 declare
616 begin
625 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
626 -- place function, then a temporary return object needs to be created
627 -- and access to it must be passed to the function. Currently we limit
628 -- such functions to those with inherently limited result subtypes, but
629 -- eventually we plan to expand the functions that are treated as
630 -- build-in-place to include other composite result types.
634 then
638 -- Remaining processing depends on specific attribute
642 ------------
643 -- Access --
644 ------------
646 when Attribute_Access |
647 Attribute_Unchecked_Access |
648 Attribute_Unrestricted_Access =>
654 begin
655 -- In order to improve the text of error messages, the designated
656 -- type of access-to-subprogram itypes is set by the semantics as
657 -- the associated subprogram entity (see sem_attr). Now we replace
658 -- such node with the proper E_Subprogram_Type itype.
662 then
663 -- The following conditions ensure that this special management
664 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
665 -- At this stage other cases in which the designated type is
666 -- still a subprogram (instead of an E_Subprogram_Type) are
667 -- wrong because the semantics must have overridden the type of
668 -- the node with the type imposed by the context.
672 then
675 else
676 declare
685 begin
694 loop
698 -- Handle itypes. There is no need to duplicate
699 -- here the itypes associated with record types
700 -- (i.e the implicit full view of private types).
704 then
724 -- Now that the explicit formals have been duplicated,
725 -- any extra formals needed by the subprogram must be
726 -- created.
741 -- If prefix is a type name, this is a reference to the current
742 -- instance of the type, within its initialization procedure.
746 then
747 declare
751 begin
752 -- If the current instance name denotes a task type, then
753 -- the access attribute is rewritten to be the name of the
754 -- "_task" parameter associated with the task type's task
755 -- procedure. An unchecked conversion is applied to ensure
756 -- a type match in cases of expander-generated calls (e.g.
757 -- init procs).
760 Formal :=
774 -- The expression must appear in a default expression,
775 -- (which in the initialization procedure is the
776 -- right-hand side of an assignment), and not in a
777 -- discriminant constraint.
779 else
802 -- If the prefix of an Access attribute is a dereference of an
803 -- access parameter (or a renaming of such a dereference) and
804 -- the context is a general access type (but not an anonymous
805 -- access type), then rewrite the attribute as a conversion of
806 -- the access parameter to the context access type. This will
807 -- result in an accessibility check being performed, if needed.
809 -- (X.all'Access => Acc_Type (X))
811 -- Note: Limit the expansion of an attribute applied to a
812 -- dereference of an access parameter so that it's only done
813 -- for 'Access. This fixes a problem with 'Unrestricted_Access
814 -- that leads to errors in the case where the attribute type
815 -- is access-to-variable and the access parameter is
816 -- access-to-constant. The conversion is only done to get
817 -- accessibility checks, so it makes sense to limit it to
818 -- 'Access.
825 = E_Anonymous_Access_Type
828 then
833 -- Ada 2005 (AI-251): If the designated type is an interface we
834 -- add an implicit conversion to force the displacement of the
835 -- pointer to reference the secondary dispatch table.
842 then
845 -- No implicit conversion required if types match
856 -- When the object is an explicit dereference, convert the
857 -- dereference's prefix.
859 else
860 declare
862 Base_Type
863 (Directly_Designated_Type
865 begin
866 -- No implicit conversion required if designated types
867 -- match.
872 then
883 --------------
884 -- Adjacent --
885 --------------
887 -- Transforms 'Adjacent into a call to the floating-point attribute
888 -- function Adjacent in Fat_xxx (where xxx is the root type)
893 -------------
894 -- Address --
895 -------------
900 begin
901 -- If the prefix is a task or a task type, the useful address is that
902 -- of the procedure for the task body, i.e. the actual program unit.
903 -- We replace the original entity with that of the procedure.
907 then
922 -- Similarly, the address of a protected operation is the address
923 -- of the corresponding protected body, regardless of the protected
924 -- object from which it is selected.
929 then
931 New_Occurrence_Of (
937 then
938 -- The prefix is be a dereference of an access_to_protected_
939 -- subprogram. The desired address is the second component of
940 -- the record that represents the access.
942 declare
948 begin
959 -- Ada 2005 (AI-251): Class-wide interface objects are always
960 -- "displaced" to reference the tag associated with the interface
961 -- type. In order to obtain the real address of such objects we
962 -- generate a call to a run-time subprogram that returns the base
963 -- address of the object.
965 -- This processing is not needed in the VM case, where dispatching
966 -- issues are taken care of by the virtual machine.
973 then
983 -- Deal with packed array reference, other cases are handled by
984 -- the back end.
991 ---------------
992 -- Alignment --
993 ---------------
998 begin
999 -- For class-wide types, X'Class'Alignment is transformed into a
1000 -- direct reference to the Alignment of the class type, so that the
1001 -- back end does not have to deal with the X'Class'Alignment
1002 -- reference.
1006 then
1010 -- For x'Alignment applied to an object of a class wide type,
1011 -- transform X'Alignment into a call to the predefined primitive
1012 -- operation _Alignment applied to X.
1016 -- No need to do anything else compiling under restriction
1017 -- No_Dispatching_Calls. During the semantic analysis we
1018 -- already notified such violation.
1024 New_Node :=
1026 Name => New_Reference_To
1032 -- The context is a specific integer type with which the
1033 -- original attribute was compatible. The function has a
1034 -- specific type as well, so to preserve the compatibility
1035 -- we must convert explicitly.
1044 -- For all other cases, we just have to deal with the case of
1045 -- the fact that the result can be universal.
1047 else
1052 ---------------
1053 -- AST_Entry --
1054 ---------------
1062 -- The reference to the entry or entry family
1065 -- The index expression for an entry family reference, or
1066 -- the Empty if Entry_Ref references a simple entry.
1068 begin
1072 else
1077 -- Get expression for Task_Id and the entry entity
1080 T_Id :=
1088 else
1089 T_Id :=
1095 -- We have to find the enclosing task to get the task type
1096 -- There must be one, since we already validated this earlier
1104 -- Now rewrite the attribute with a call to Create_AST_Handler
1110 T_Id,
1116 ------------------
1117 -- Bit_Position --
1118 ------------------
1120 -- We compute this if a component clause was present, otherwise we leave
1121 -- the computation up to the back end, since we don't know what layout
1122 -- will be chosen.
1124 -- Note that the attribute can apply to a naked record component
1125 -- in generated code (i.e. the prefix is an identifier that
1126 -- references the component or discriminant entity).
1129 declare
1132 begin
1135 else
1145 else
1150 ------------------
1151 -- Body_Version --
1152 ------------------
1154 -- A reference to P'Body_Version or P'Version is expanded to
1156 -- Vnn : Unsigned;
1157 -- pragma Import (C, Vnn, "uuuuT";
1158 -- ...
1159 -- Get_Version_String (Vnn)
1161 -- where uuuu is the unit name (dots replaced by double underscore)
1162 -- and T is B for the cases of Body_Version, or Version applied to a
1163 -- subprogram acting as its own spec, and S for Version applied to a
1164 -- subprogram spec or package. This sequence of code references the
1165 -- the unsigned constant created in the main program by the binder.
1167 -- A special exception occurs for Standard, where the string
1168 -- returned is a copy of the library string in gnatvsn.ads.
1176 begin
1177 -- If not library unit, get to containing library unit
1183 loop
1187 -- Special case Standard and Standard.ASCII
1194 -- All other cases
1196 else
1197 -- Build required string constant
1201 Start_String;
1205 else
1210 -- Case of subprogram acting as its own spec, always use body
1214 N_Subprogram_Body
1216 then
1219 -- Case of no body present, always use spec
1224 -- Otherwise use B for Body_Version, S for spec
1228 else
1235 -- Insert the object declaration
1240 Object_Definition =>
1243 -- Set entity as imported with correct external name
1248 -- Set entity as internal to ensure proper Sprint output of its
1249 -- implicit importation.
1253 -- And now rewrite original reference
1265 -------------
1266 -- Ceiling --
1267 -------------
1269 -- Transforms 'Ceiling into a call to the floating-point attribute
1270 -- function Ceiling in Fat_xxx (where xxx is the root type)
1275 --------------
1276 -- Callable --
1277 --------------
1279 -- Transforms 'Callable attribute into a call to the Callable function
1282 begin
1283 -- We have an object of a task interface class-wide type as a prefix
1284 -- to Callable. Generate:
1286 -- callable (Task_Id (Pref._disp_get_task_id));
1292 then
1295 Name =>
1299 Subtype_Mark =>
1301 Expression =>
1303 Prefix =>
1305 Selector_Name =>
1308 else
1316 ------------
1317 -- Caller --
1318 ------------
1320 -- Transforms 'Caller attribute into a call to either the
1321 -- Task_Entry_Caller or the Protected_Entry_Caller function.
1331 begin
1332 -- Protected case
1337 Name :=
1338 New_Reference_To
1342 Name :=
1343 New_Reference_To
1355 New_Reference_To
1358 -- Task case
1360 else
1361 -- Determine the nesting depth of the E'Caller attribute, that
1362 -- is, how many accept statements are nested within the accept
1363 -- statement for E at the point of E'Caller. The runtime uses
1364 -- this depth to find the specified entry call.
1369 -- We should not reach the scope of the entry, as it should
1370 -- already have been checked in Sem_Attr that this attribute
1371 -- reference is within a matching accept statement.
1386 Name =>
1396 -------------
1397 -- Compose --
1398 -------------
1400 -- Transforms 'Compose into a call to the floating-point attribute
1401 -- function Compose in Fat_xxx (where xxx is the root type)
1403 -- Note: we strictly should have special code here to deal with the
1404 -- case of absurdly negative arguments (less than Integer'First)
1405 -- which will return a (signed) zero value, but it hardly seems
1406 -- worth the effort. Absurdly large positive arguments will raise
1407 -- constraint error which is fine.
1412 -----------------
1413 -- Constrained --
1414 -----------------
1420 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
1421 -- view of an aliased object whose subtype is constrained.
1423 ---------------------------------
1424 -- Is_Constrained_Aliased_View --
1425 ---------------------------------
1430 begin
1436 else
1440 else
1442 and then
1445 and then
1446 not Has_Constrained_Partial_View
1451 -- Start of processing for Constrained
1453 begin
1454 -- Reference to a parameter where the value is passed as an extra
1455 -- actual, corresponding to the extra formal referenced by the
1456 -- Extra_Constrained field of the corresponding formal. If this
1457 -- is an entry in-parameter, it is replaced by a constant renaming
1458 -- for which Extra_Constrained is never created.
1463 then
1465 New_Occurrence_Of
1468 -- For variables with a Extra_Constrained field, we use the
1469 -- corresponding entity.
1474 then
1476 New_Occurrence_Of
1479 -- For all other entity names, we can tell at compile time
1482 declare
1486 begin
1487 -- (RM J.4) obsolescent cases
1491 -- Private type
1497 -- It not a private type, must be a generic actual type
1498 -- that corresponded to a private type. We know that this
1499 -- correspondence holds, since otherwise the reference
1500 -- within the generic template would have been illegal.
1502 else
1505 else
1510 -- If the prefix is not a variable or is aliased, then
1511 -- definitely true; if it's a formal parameter without an
1512 -- associated extra formal, then treat it as constrained.
1514 -- Ada 2005 (AI-363): An aliased prefix must be known to be
1515 -- constrained in order to set the attribute to True.
1523 then
1526 -- Variable case, look at type to see if it is constrained.
1527 -- Note that the one case where this is not accurate (the
1528 -- procedure formal case), has been handled above.
1530 -- We use the Underlying_Type here (and below) in case the
1531 -- type is private without discriminants, but the full type
1532 -- has discriminants. This case is illegal, but we generate it
1533 -- internally for passing to the Extra_Constrained parameter.
1535 else
1543 -- Prefix is not an entity name. These are also cases where we can
1544 -- always tell at compile time by looking at the form and type of the
1545 -- prefix. If an explicit dereference of an object with constrained
1546 -- partial view, this is unconstrained (Ada 2005 AI-363).
1548 else
1550 New_Reference_To (
1551 Boolean_Literals (
1553 or else
1555 and then
1558 Loc));
1564 ---------------
1565 -- Copy_Sign --
1566 ---------------
1568 -- Transforms 'Copy_Sign into a call to the floating-point attribute
1569 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
1574 -----------
1575 -- Count --
1576 -----------
1578 -- Transforms 'Count attribute into a call to the Count function
1588 begin
1589 -- If the prefix is a member of an entry family, retrieve both
1590 -- entry name and index. For a simple entry there is no index.
1595 else
1602 -- Find the concurrent type in which this attribute is referenced
1603 -- (there had better be one).
1610 -- Protected case
1617 Call :=
1621 New_Reference_To
1623 Entry_Index_Expression
1627 Name :=
1630 Call :=
1634 New_Reference_To
1641 -- Task case
1643 else
1644 Call :=
1652 -- The call returns type Natural but the context is universal integer
1653 -- so any integer type is allowed. The attribute was already resolved
1654 -- so its Etype is the required result type. If the base type of the
1655 -- context type is other than Standard.Integer we put in a conversion
1656 -- to the required type. This can be a normal typed conversion since
1657 -- both input and output types of the conversion are integer types
1661 else
1668 ---------------
1669 -- Elab_Body --
1670 ---------------
1672 -- This processing is shared by Elab_Spec
1674 -- What we do is to insert the following declarations
1676 -- procedure tnn;
1677 -- pragma Import (C, enn, "name___elabb/s");
1679 -- and then the Elab_Body/Spec attribute is replaced by a reference
1680 -- to this defining identifier.
1682 when Attribute_Elab_Body |
1683 Attribute_Elab_Spec =>
1693 -- Given Nod, an identifier, or a selected component, put the
1694 -- image into the current string literal, with double underline
1695 -- between components.
1697 ----------------------
1698 -- Make_Elab_String --
1699 ----------------------
1702 begin
1718 else
1726 -- Start of processing for Elab_Body/Elab_Spec
1728 begin
1729 -- First we need to prepare the string literal for the name of
1730 -- the elaboration routine to be referenced.
1732 Start_String;
1738 else
1745 else
1753 Specification =>
1764 Expression =>
1768 Expression =>
1775 ----------------
1776 -- Elaborated --
1777 ----------------
1779 -- Elaborated is always True for preelaborated units, predefined units,
1780 -- pure units and units which have Elaborate_Body pragmas. These units
1781 -- have no elaboration entity.
1783 -- Note: The Elaborated attribute is never passed to the back end
1788 begin
1792 else
1797 --------------
1798 -- Enum_Rep --
1799 --------------
1802 begin
1803 -- X'Enum_Rep (Y) expands to
1805 -- target-type (Y)
1807 -- This is simply a direct conversion from the enumeration type to
1808 -- the target integer type, which is treated by the back end as a
1809 -- normal integer conversion, treating the enumeration type as an
1810 -- integer, which is exactly what we want! We set Conversion_OK to
1811 -- make sure that the analyzer does not complain about what otherwise
1812 -- might be an illegal conversion.
1818 -- X'Enum_Rep where X is an enumeration literal is replaced by
1819 -- the literal value.
1825 -- If this is a renaming of a literal, recover the representation
1826 -- of the original.
1830 and then
1832 = E_Enumeration_Literal
1833 then
1838 -- X'Enum_Rep where X is an object does a direct unchecked conversion
1839 -- of the object value, as described for the type case above.
1841 else
1850 --------------
1851 -- Enum_Val --
1852 --------------
1858 begin
1859 -- X'Enum_Val (Y) expands to
1861 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
1862 -- X!(Y);
1868 Condition =>
1870 Left_Opnd =>
1872 Name =>
1885 --------------
1886 -- Exponent --
1887 --------------
1889 -- Transforms 'Exponent into a call to the floating-point attribute
1890 -- function Exponent in Fat_xxx (where xxx is the root type)
1895 ------------------
1896 -- External_Tag --
1897 ------------------
1899 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
1902 begin
1914 -----------
1915 -- First --
1916 -----------
1920 -- If the prefix type is a constrained packed array type which
1921 -- already has a Packed_Array_Type representation defined, then
1922 -- replace this attribute with a direct reference to 'First of the
1923 -- appropriate index subtype (since otherwise the back end will try
1924 -- to give us the value of 'First for this implementation type).
1937 ---------------
1938 -- First_Bit --
1939 ---------------
1941 -- Compute this if component clause was present, otherwise we leave the
1942 -- computation to be completed in the back-end, since we don't know what
1943 -- layout will be chosen.
1948 begin
1956 else
1961 -----------------
1962 -- Fixed_Value --
1963 -----------------
1965 -- We transform:
1967 -- fixtype'Fixed_Value (integer-value)
1969 -- into
1971 -- fixtype(integer-value)
1973 -- We do all the required analysis of the conversion here, because we do
1974 -- not want this to go through the fixed-point conversion circuits. Note
1975 -- that the back end always treats fixed-point as equivalent to the
1976 -- corresponding integer type anyway.
1979 begin
1987 -- Note: it might appear that a properly analyzed unchecked conversion
1988 -- would be just fine here, but that's not the case, since the full
1989 -- range checks performed by the following call are critical!
1994 -----------
1995 -- Floor --
1996 -----------
1998 -- Transforms 'Floor into a call to the floating-point attribute
1999 -- function Floor in Fat_xxx (where xxx is the root type)
2004 ----------
2005 -- Fore --
2006 ----------
2008 -- For the fixed-point type Typ:
2010 -- Typ'Fore
2012 -- expands into
2014 -- Result_Type (System.Fore (Universal_Real (Type'First)),
2015 -- Universal_Real (Type'Last))
2017 -- Note that we know that the type is a non-static subtype, or Fore
2018 -- would have itself been computed dynamically in Eval_Attribute.
2040 --------------
2041 -- Fraction --
2042 --------------
2044 -- Transforms 'Fraction into a call to the floating-point attribute
2045 -- function Fraction in Fat_xxx (where xxx is the root type)
2050 --------------
2051 -- Identity --
2052 --------------
2054 -- For an exception returns a reference to the exception data:
2055 -- Exception_Id!(Prefix'Reference)
2057 -- For a task it returns a reference to the _task_id component of
2058 -- corresponding record:
2060 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
2062 -- in Ada.Task_Identification
2067 begin
2077 else
2080 -- If the prefix is a task interface, the Task_Id is obtained
2081 -- dynamically through a dispatching call, as for other task
2082 -- attributes applied to interfaces.
2088 then
2092 Prefix =>
2094 Selector_Name =>
2097 else
2106 -----------
2107 -- Image --
2108 -----------
2110 -- Image attribute is handled in separate unit Exp_Imgv
2115 ---------
2116 -- Img --
2117 ---------
2119 -- X'Img is expanded to typ'Image (X), where typ is the type of X
2122 begin
2132 -----------
2133 -- Input --
2134 -----------
2149 -- Value for controlling argument in call. Always Empty except in
2150 -- the dispatching (class-wide type) case, where it is a reference
2151 -- to the dummy object initialized to the right internal tag.
2154 -- The expansion of the attribute reference may generate a call to
2155 -- a user-defined stream subprogram that is frozen by the call. This
2156 -- can lead to access-before-elaboration problem if the reference
2157 -- appears in an object declaration and the subprogram body has not
2158 -- been seen. The freezing of the subprogram requires special code
2159 -- because it appears in an expanded context where expressions do
2160 -- not freeze their constituents.
2162 ------------------------------
2163 -- Freeze_Stream_Subprogram --
2164 ------------------------------
2170 begin
2171 -- If this is user-defined subprogram, the corresponding
2172 -- stream function appears as a renaming-as-body, and the
2173 -- user subprogram must be retrieved by tree traversal.
2178 then
2182 N_Subprogram_Renaming_Declaration
2183 then
2189 -- Start of processing for Input
2191 begin
2192 -- If no underlying type, we have an error that will be diagnosed
2193 -- elsewhere, so here we just completely ignore the expansion.
2199 -- If there is a TSS for Input, just call it
2206 else
2207 -- If there is a Stream_Convert pragma, use it, we rewrite
2209 -- sourcetyp'Input (stream)
2211 -- as
2213 -- sourcetyp (streamread (strmtyp'Input (stream)));
2215 -- where streamread is the given Read function that converts an
2216 -- argument of type strmtyp to type sourcetyp or a type from which
2217 -- it is derived (extra conversion required for the derived case).
2231 Prefix =>
2232 New_Occurrence_Of
2240 -- Elementary types
2244 -- A special case arises if we have a defined _Read routine,
2245 -- since in this case we are required to call this routine.
2248 Build_Record_Or_Elementary_Input_Function
2252 -- For normal cases, we call the I_xxx routine directly
2254 else
2260 -- Array type case
2266 -- Dispatching case with class-wide type
2270 -- No need to do anything else compiling under restriction
2271 -- No_Dispatching_Calls. During the semantic analysis we
2272 -- already notified such violation.
2278 declare
2283 begin
2284 -- Read the internal tag (RM 13.13.2(34)) and use it to
2285 -- initialize a dummy tag object:
2287 -- Dnn : Ada.Tags.Tag
2288 -- := Descendant_Tag (String'Input (Strm), P_Type);
2290 -- This dummy object is used only to provide a controlling
2291 -- argument for the eventual _Input call. Descendant_Tag is
2292 -- called rather than Internal_Tag to ensure that we have a
2293 -- tag for a type that is descended from the prefix type and
2294 -- declared at the same accessibility level (the exception
2295 -- Tag_Error will be raised otherwise). The level check is
2296 -- required for Ada 2005 because tagged types can be
2297 -- extended in nested scopes (AI-344).
2299 Dnn :=
2303 Decl :=
2306 Object_Definition =>
2308 Expression =>
2310 Name =>
2314 Prefix =>
2318 Relocate_Node
2326 -- Now we need to get the entity for the call, and construct
2327 -- a function call node, where we preset a reference to Dnn
2328 -- as the controlling argument (doing an unchecked convert
2329 -- to the class-wide tagged type to make it look like a real
2330 -- tagged object).
2339 -- For tagged types, use the primitive Input function
2344 -- All other record type cases, including protected records. The
2345 -- latter only arise for expander generated code for handling
2346 -- shared passive partition access.
2348 else
2349 pragma Assert
2352 -- Ada 2005 (AI-216): Program_Error is raised executing default
2353 -- implementation of the Input attribute of an unchecked union
2354 -- type if the type lacks default discriminant values.
2358 then
2366 Build_Record_Or_Elementary_Input_Function
2372 then
2373 -- The stream function may contain calls to user-defined
2374 -- Read procedures for individual components.
2376 declare
2380 begin
2383 Func :=
2384 Find_Stream_Subprogram
2398 -- If we fall through, Fname is the function to be called. The result
2399 -- is obtained by calling the appropriate function, then converting
2400 -- the result. The conversion does a subtype check.
2402 Call :=
2417 -------------------
2418 -- Integer_Value --
2419 -------------------
2421 -- We transform
2423 -- inttype'Fixed_Value (fixed-value)
2425 -- into
2427 -- inttype(integer-value))
2429 -- we do all the required analysis of the conversion here, because we do
2430 -- not want this to go through the fixed-point conversion circuits. Note
2431 -- that the back end always treats fixed-point as equivalent to the
2432 -- corresponding integer type anyway.
2435 begin
2443 -- Note: it might appear that a properly analyzed unchecked conversion
2444 -- would be just fine here, but that's not the case, since the full
2445 -- range checks performed by the following call are critical!
2450 -------------------
2451 -- Invalid_Value --
2452 -------------------
2457 ----------
2458 -- Last --
2459 ----------
2463 -- If the prefix type is a constrained packed array type which
2464 -- already has a Packed_Array_Type representation defined, then
2465 -- replace this attribute with a direct reference to 'Last of the
2466 -- appropriate index subtype (since otherwise the back end will try
2467 -- to give us the value of 'Last for this implementation type).
2480 --------------
2481 -- Last_Bit --
2482 --------------
2484 -- We compute this if a component clause was present, otherwise we leave
2485 -- the computation up to the back end, since we don't know what layout
2486 -- will be chosen.
2491 begin
2494 then
2502 else
2507 ------------------
2508 -- Leading_Part --
2509 ------------------
2511 -- Transforms 'Leading_Part into a call to the floating-point attribute
2512 -- function Leading_Part in Fat_xxx (where xxx is the root type)
2514 -- Note: strictly, we should generate special case code to deal with
2515 -- absurdly large positive arguments (greater than Integer'Last), which
2516 -- result in returning the first argument unchanged, but it hardly seems
2517 -- worth the effort. We raise constraint error for absurdly negative
2518 -- arguments which is fine.
2523 ------------
2524 -- Length --
2525 ------------
2531 begin
2532 -- Processing for packed array types
2537 -- If the index type, Ityp, is an enumeration type with holes,
2538 -- then we calculate X'Length explicitly using
2540 -- Typ'Max
2541 -- (0, Ityp'Pos (X'Last (N)) -
2542 -- Ityp'Pos (X'First (N)) + 1);
2544 -- Since the bounds in the template are the representation values
2545 -- and the back end would get the wrong value.
2549 then
2552 else
2560 Expressions => New_List
2564 Left_Opnd =>
2566 Left_Opnd =>
2578 Right_Opnd =>
2585 Prefix =>
2596 -- If the prefix type is a constrained packed array type which
2597 -- already has a Packed_Array_Type representation defined, then
2598 -- replace this attribute with a direct reference to 'Range_Length
2599 -- of the appropriate index subtype (since otherwise the back end
2600 -- will try to give us the value of 'Length for this
2601 -- implementation type).
2611 -- Access type case
2616 -- If the designated type is a packed array type, then we convert
2617 -- the reference to:
2619 -- typ'Max (0, 1 +
2620 -- xtyp'Pos (Pref'Last (Expr)) -
2621 -- xtyp'Pos (Pref'First (Expr)));
2623 -- This is a bit complex, but it is the easiest thing to do that
2624 -- works in all cases including enum types with holes xtyp here
2625 -- is the appropriate index type.
2627 declare
2631 begin
2645 Left_Opnd =>
2653 Expressions =>
2656 Right_Opnd =>
2662 Prefix =>
2665 Expressions =>
2672 -- Otherwise leave it to the back end
2674 else
2679 -------------
2680 -- Machine --
2681 -------------
2683 -- Transforms 'Machine into a call to the floating-point attribute
2684 -- function Machine in Fat_xxx (where xxx is the root type)
2689 ----------------------
2690 -- Machine_Rounding --
2691 ----------------------
2693 -- Transforms 'Machine_Rounding into a call to the floating-point
2694 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
2695 -- type). Expansion is avoided for cases the back end can handle
2696 -- directly.
2703 ------------------
2704 -- Machine_Size --
2705 ------------------
2707 -- Machine_Size is equivalent to Object_Size, so transform it into
2708 -- Object_Size and that way the back end never sees Machine_Size.
2718 --------------
2719 -- Mantissa --
2720 --------------
2722 -- The only case that can get this far is the dynamic case of the old
2723 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
2724 -- we expand:
2726 -- typ'Mantissa
2728 -- into
2730 -- ityp (System.Mantissa.Mantissa_Value
2731 -- (Integer'Integer_Value (typ'First),
2732 -- Integer'Integer_Value (typ'Last)));
2763 --------------------
2764 -- Mechanism_Code --
2765 --------------------
2769 -- We must replace the prefix in the renamed case
2773 then
2777 ---------
2778 -- Mod --
2779 ---------
2786 begin
2788 -- This is not so simple. The issue is what type to use for the
2789 -- computation of the modular value.
2791 -- The easy case is when the modulus value is within the bounds
2792 -- of the signed integer type of the argument. In this case we can
2793 -- just do the computation in that signed integer type, and then
2794 -- do an ordinary conversion to the target type.
2803 -- Here we know that the modulus is larger than type'Last of the
2804 -- integer type. There are two cases to consider:
2806 -- a) The integer value is non-negative. In this case, it is
2807 -- returned as the result (since it is less than the modulus).
2809 -- b) The integer value is negative. In this case, we know that the
2810 -- result is modulus + value, where the value might be as small as
2811 -- -modulus. The trouble is what type do we use to do the subtract.
2812 -- No type will do, since modulus can be as big as 2**64, and no
2813 -- integer type accommodates this value. Let's do bit of algebra
2815 -- modulus + value
2816 -- = modulus - (-value)
2817 -- = (modulus - 1) - (-value - 1)
2819 -- Now modulus - 1 is certainly in range of the modular type.
2820 -- -value is in the range 1 .. modulus, so -value -1 is in the
2821 -- range 0 .. modulus-1 which is in range of the modular type.
2822 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
2823 -- which we can compute using the integer base type.
2825 -- Once this is done we analyze the conditional expression without
2826 -- range checks, because we know everything is in range, and we
2827 -- want to prevent spurious warnings on either branch.
2829 else
2841 Left_Opnd =>
2844 Right_Opnd =>
2847 Right_Opnd =>
2850 Right_Opnd =>
2859 -----------
2860 -- Model --
2861 -----------
2863 -- Transforms 'Model into a call to the floating-point attribute
2864 -- function Model in Fat_xxx (where xxx is the root type)
2869 -----------------
2870 -- Object_Size --
2871 -----------------
2873 -- The processing for Object_Size shares the processing for Size
2875 ---------
2876 -- Old --
2877 ---------
2886 begin
2887 -- Find the nearest subprogram body, ignoring _Preconditions
2890 loop
2896 -- Insert the assignment at the start of the declarations
2898 Asn_Stm :=
2908 else
2915 ------------
2916 -- Output --
2917 ------------
2928 begin
2929 -- If no underlying type, we have an error that will be diagnosed
2930 -- elsewhere, so here we just completely ignore the expansion.
2936 -- If TSS for Output is present, just call it
2943 else
2944 -- If there is a Stream_Convert pragma, use it, we rewrite
2946 -- sourcetyp'Output (stream, Item)
2948 -- as
2950 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
2952 -- where strmwrite is the given Write function that converts an
2953 -- argument of type sourcetyp or a type acctyp, from which it is
2954 -- derived to type strmtyp. The conversion to acttyp is required
2955 -- for the derived case.
2960 Arg3 :=
2979 -- For elementary types, we call the W_xxx routine directly.
2980 -- Note that the effect of Write and Output is identical for
2981 -- the case of an elementary type, since there are no
2982 -- discriminants or bounds.
2986 -- A special case arises if we have a defined _Write routine,
2987 -- since in this case we are required to call this routine.
2990 Build_Record_Or_Elementary_Output_Procedure
2994 -- For normal cases, we call the W_xxx routine directly
2996 else
3002 -- Array type case
3008 -- Class-wide case, first output external tag, then dispatch
3009 -- to the appropriate primitive Output function (RM 13.13.2(31)).
3013 -- No need to do anything else compiling under restriction
3014 -- No_Dispatching_Calls. During the semantic analysis we
3015 -- already notified such violation.
3025 begin
3026 -- Ada 2005 (AI-344): Check that the accessibility level
3027 -- of the type of the output object is not deeper than
3028 -- that of the attribute's prefix type.
3030 -- if Get_Access_Level (Item'Tag)
3031 -- /= Get_Access_Level (P_Type'Tag)
3032 -- then
3033 -- raise Tag_Error;
3034 -- end if;
3036 -- String'Output (Strm, External_Tag (Item'Tag));
3038 -- We cannot figure out a practical way to implement this
3039 -- accessibility check on virtual machines, so we omit it.
3043 then
3046 Condition =>
3048 Left_Opnd =>
3051 Prefix =>
3052 Relocate_Node (
3057 Right_Opnd =>
3061 Then_Statements =>
3063 New_Occurrence_Of (
3074 Name =>
3078 Prefix =>
3079 Relocate_Node
3086 -- Tagged type case, use the primitive Output function
3091 -- All other record type cases, including protected records.
3092 -- The latter only arise for expander generated code for
3093 -- handling shared passive partition access.
3095 else
3096 pragma Assert
3099 -- Ada 2005 (AI-216): Program_Error is raised when executing
3100 -- the default implementation of the Output attribute of an
3101 -- unchecked union type if the type lacks default discriminant
3102 -- values.
3106 then
3114 Build_Record_Or_Elementary_Output_Procedure
3120 -- If we fall through, Pname is the name of the procedure to call
3125 ---------
3126 -- Pos --
3127 ---------
3129 -- For enumeration types with a standard representation, Pos is
3130 -- handled by the back end.
3132 -- For enumeration types, with a non-standard representation we
3133 -- generate a call to the _Rep_To_Pos function created when the
3134 -- type was frozen. The call has the form
3136 -- _rep_to_pos (expr, flag)
3138 -- The parameter flag is True if range checks are enabled, causing
3139 -- Program_Error to be raised if the expression has an invalid
3140 -- representation, and False if range checks are suppressed.
3142 -- For integer types, Pos is equivalent to a simple integer
3143 -- conversion and we rewrite it as such
3146 declare
3149 begin
3150 -- Deal with zero/non-zero boolean values
3158 -- Case of enumeration type
3162 -- Non-standard enumeration type (generate call)
3169 Name =>
3175 -- Standard enumeration type (do universal integer check)
3177 else
3181 -- Deal with integer types (replace by conversion)
3190 --------------
3191 -- Position --
3192 --------------
3194 -- We compute this if a component clause was present, otherwise we leave
3195 -- the computation up to the back end, since we don't know what layout
3196 -- will be chosen.
3199 declare
3202 begin
3209 else
3214 ----------
3215 -- Pred --
3216 ----------
3218 -- 1. Deal with enumeration types with holes
3219 -- 2. For floating-point, generate call to attribute function
3220 -- 3. For other cases, deal with constraint checking
3223 declare
3226 begin
3228 -- For enumeration types with non-standard representations, we
3229 -- expand typ'Pred (x) into
3231 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
3233 -- If the representation is contiguous, we compute instead
3234 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
3235 -- The conversion function Enum_Pos_To_Rep is defined on the
3236 -- base type, not the subtype, so we have to use the base type
3237 -- explicitly for this and other enumeration attributes.
3241 then
3246 Left_Opnd =>
3249 Right_Opnd =>
3251 Name =>
3252 New_Reference_To
3255 Parameter_Associations =>
3256 New_List (
3259 Left_Opnd =>
3262 Right_Opnd =>
3266 else
3267 -- Add Boolean parameter True, to request program errror if
3268 -- we have a bad representation on our hands. If checks are
3269 -- suppressed, then add False instead
3274 Prefix =>
3275 New_Reference_To
3279 Left_Opnd =>
3281 Name =>
3282 New_Reference_To
3290 -- For floating-point, we transform 'Pred into a call to the Pred
3291 -- floating-point attribute function in Fat_xxx (xxx is root type)
3297 -- For modular types, nothing to do (no overflow, since wraps)
3302 -- For other types, if range checking is enabled, we must generate
3303 -- a check if overflow checking is enabled.
3310 --------------
3311 -- Priority --
3312 --------------
3314 -- Ada 2005 (AI-327): Dynamic ceiling priorities
3316 -- We rewrite X'Priority as the following run-time call:
3318 -- Get_Ceiling (X._Object)
3320 -- Note that although X'Priority is notionally an object, it is quite
3321 -- deliberately not defined as an aliased object in the RM. This means
3322 -- that it works fine to rewrite it as a call, without having to worry
3323 -- about complications that would other arise from X'Priority'Access,
3324 -- which is illegal, because of the lack of aliasing.
3327 declare
3334 begin
3335 -- Look for the enclosing concurrent type
3344 -- Generate the actual of the call
3351 -- Use of 'Priority inside protected entries and barriers (in
3352 -- both cases the type of the first formal of their expanded
3353 -- subprogram is Address)
3357 then
3358 declare
3361 begin
3362 -- In the expansion of protected entries the type of the
3363 -- first formal of the Protected_Body_Subprogram is an
3364 -- Address. In order to reference the _object component
3365 -- we generate:
3367 -- type T is access p__ptTV;
3368 -- freeze T []
3376 -- Generate:
3377 -- T!(O)._object'unchecked_access
3379 Object_Parm :=
3381 Prefix =>
3383 Prefix =>
3385 New_Reference_To
3386 (First_Entity
3388 Loc)),
3389 Selector_Name =>
3394 -- Use of 'Priority inside a protected subprogram
3396 else
3397 Object_Parm :=
3399 Prefix =>
3401 Prefix => New_Reference_To
3402 (First_Entity
3404 Loc),
3405 Selector_Name =>
3410 -- Select the appropriate run-time subprogram
3413 RT_Subprg_Name :=
3415 else
3416 RT_Subprg_Name :=
3420 Call :=
3427 -- Avoid the generation of extra checks on the pointer to the
3428 -- protected object.
3433 ------------------
3434 -- Range_Length --
3435 ------------------
3438 -- The only special processing required is for the case where
3439 -- Range_Length is applied to an enumeration type with holes.
3440 -- In this case we transform
3442 -- X'Range_Length
3444 -- to
3446 -- X'Pos (X'Last) - X'Pos (X'First) + 1
3448 -- So that the result reflects the proper Pos values instead
3449 -- of the underlying representations.
3453 then
3456 Left_Opnd =>
3458 Left_Opnd =>
3467 Right_Opnd =>
3476 Right_Opnd =>
3481 -- For all other cases, the attribute is handled by the back end, but
3482 -- we need to deal with the case of the range check on a universal
3483 -- integer.
3485 else
3490 ----------
3491 -- Read --
3492 ----------
3506 begin
3507 -- If no underlying type, we have an error that will be diagnosed
3508 -- elsewhere, so here we just completely ignore the expansion.
3514 -- The simple case, if there is a TSS for Read, just call it
3521 else
3522 -- If there is a Stream_Convert pragma, use it, we rewrite
3524 -- sourcetyp'Read (stream, Item)
3526 -- as
3528 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
3530 -- where strmread is the given Read function that converts an
3531 -- argument of type strmtyp to type sourcetyp or a type from which
3532 -- it is derived. The conversion to sourcetyp is required in the
3533 -- latter case.
3535 -- A special case arises if Item is a type conversion in which
3536 -- case, we have to expand to:
3538 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
3540 -- where Itemx is the expression of the type conversion (i.e.
3541 -- the actual object), and typex is the type of Itemx.
3549 Rhs :=
3555 Prefix =>
3556 New_Occurrence_Of
3575 -- For elementary types, we call the I_xxx routine using the first
3576 -- parameter and then assign the result into the second parameter.
3577 -- We set Assignment_OK to deal with the conversion case.
3580 declare
3584 begin
3604 -- Array type case
3610 -- Tagged type case, use the primitive Read function. Note that
3611 -- this will dispatch in the class-wide case which is what we want
3616 -- All other record type cases, including protected records. The
3617 -- latter only arise for expander generated code for handling
3618 -- shared passive partition access.
3620 else
3621 pragma Assert
3624 -- Ada 2005 (AI-216): Program_Error is raised when executing
3625 -- the default implementation of the Read attribute of an
3626 -- Unchecked_Union type.
3635 and then Present
3637 then
3638 Build_Mutable_Record_Read_Procedure
3640 else
3641 Build_Record_Read_Procedure
3645 -- Suppress checks, uninitialized or otherwise invalid
3646 -- data does not cause constraint errors to be raised for
3647 -- a complete record read.
3656 ---------------
3657 -- Remainder --
3658 ---------------
3660 -- Transforms 'Remainder into a call to the floating-point attribute
3661 -- function Remainder in Fat_xxx (where xxx is the root type)
3666 ------------
3667 -- Result --
3668 ------------
3670 -- Transform 'Result into reference to _Result formal. At the point
3671 -- where a legal 'Result attribute is expanded, we know that we are in
3672 -- the context of a _Postcondition function with a _Result parameter.
3680 -----------
3681 -- Round --
3682 -----------
3684 -- The handling of the Round attribute is quite delicate. The processing
3685 -- in Sem_Attr introduced a conversion to universal real, reflecting the
3686 -- semantics of Round, but we do not want anything to do with universal
3687 -- real at runtime, since this corresponds to using floating-point
3688 -- arithmetic.
3690 -- What we have now is that the Etype of the Round attribute correctly
3691 -- indicates the final result type. The operand of the Round is the
3692 -- conversion to universal real, described above, and the operand of
3693 -- this conversion is the actual operand of Round, which may be the
3694 -- special case of a fixed point multiplication or division (Etype =
3695 -- universal fixed)
3697 -- The exapander will expand first the operand of the conversion, then
3698 -- the conversion, and finally the round attribute itself, since we
3699 -- always work inside out. But we cannot simply process naively in this
3700 -- order. In the semantic world where universal fixed and real really
3701 -- exist and have infinite precision, there is no problem, but in the
3702 -- implementation world, where universal real is a floating-point type,
3703 -- we would get the wrong result.
3705 -- So the approach is as follows. First, when expanding a multiply or
3706 -- divide whose type is universal fixed, we do nothing at all, instead
3707 -- deferring the operation till later.
3709 -- The actual processing is done in Expand_N_Type_Conversion which
3710 -- handles the special case of Round by looking at its parent to see if
3711 -- it is a Round attribute, and if it is, handling the conversion (or
3712 -- its fixed multiply/divide child) in an appropriate manner.
3714 -- This means that by the time we get to expanding the Round attribute
3715 -- itself, the Round is nothing more than a type conversion (and will
3716 -- often be a null type conversion), so we just replace it with the
3717 -- appropriate conversion operation.
3724 --------------
3725 -- Rounding --
3726 --------------
3728 -- Transforms 'Rounding into a call to the floating-point attribute
3729 -- function Rounding in Fat_xxx (where xxx is the root type)
3734 -------------
3735 -- Scaling --
3736 -------------
3738 -- Transforms 'Scaling into a call to the floating-point attribute
3739 -- function Scaling in Fat_xxx (where xxx is the root type)
3744 ----------
3745 -- Size --
3746 ----------
3748 when Attribute_Size |
3749 Attribute_Object_Size |
3750 Attribute_Value_Size |
3753 declare
3757 begin
3758 -- Processing for VADS_Size case. Note that this processing removes
3759 -- all traces of VADS_Size from the tree, and completes all required
3760 -- processing for VADS_Size by translating the attribute reference
3761 -- to an appropriate Size or Object_Size reference.
3765 then
3766 -- If the size is specified, then we simply use the specified
3767 -- size. This applies to both types and objects. The size of an
3768 -- object can be specified in the following ways:
3770 -- An explicit size object is given for an object
3771 -- A component size is specified for an indexed component
3772 -- A component clause is specified for a selected component
3773 -- The object is a component of a packed composite object
3775 -- If the size is specified, then VADS_Size of an object
3779 or else
3784 or else
3788 then
3791 -- Otherwise if we have an object rather than a type, then the
3792 -- VADS_Size attribute applies to the type of the object, rather
3793 -- than the object itself. This is one of the respects in which
3794 -- VADS_Size differs from Size.
3796 else
3800 then
3804 -- For a scalar type for which no size was explicitly given,
3805 -- VADS_Size means Object_Size. This is the other respect in
3806 -- which VADS_Size differs from Size.
3811 -- In all other cases, Size and VADS_Size are the sane
3813 else
3819 -- For class-wide types, X'Class'Size is transformed into a direct
3820 -- reference to the Size of the class type, so that the back end does
3821 -- not have to deal with the X'Class'Size reference.
3825 then
3829 -- For X'Size applied to an object of a class-wide type, transform
3830 -- X'Size into a call to the primitive operation _Size applied to X.
3834 -- No need to do anything else compiling under restriction
3835 -- No_Dispatching_Calls. During the semantic analysis we
3836 -- already notified such violation.
3842 New_Node :=
3844 Name => New_Reference_To
3850 -- The context is a specific integer type with which the
3851 -- original attribute was compatible. The function has a
3852 -- specific type as well, so to preserve the compatibility
3853 -- we must convert explicitly.
3862 -- Case of known RM_Size of a type
3868 then
3871 -- Case of known Esize of a type
3877 then
3880 -- Case of known size of object
3887 then
3890 -- For an array component, we can do Size in the front end
3891 -- if the component_size of the array is set.
3896 -- For a record component, we can do Size in the front end if there
3897 -- is a component clause, or if the record is packed and the
3898 -- component's size is known at compile time.
3901 declare
3905 begin
3912 else
3918 -- All other cases are handled by the back end
3920 else
3923 -- If Size is applied to a formal parameter that is of a packed
3924 -- array subtype, then apply Size to the actual subtype.
3930 then
3933 Prefix =>
3939 -- If Size applies to a dereference of an access to unconstrained
3940 -- packed array, the back end needs to see its unconstrained
3941 -- nominal type, but also a hint to the actual constrained type.
3947 then
3955 -- Common processing for record and array component case
3958 declare
3961 begin
3964 -- This integer literal is not a static expression. We do not
3965 -- call Analyze_And_Resolve here, because this would activate
3966 -- the circuit for deciding that a static value was out of
3967 -- range, and we don't want that.
3969 -- So just manually set the type, mark the expression as non-
3970 -- static, and then ensure that the result is checked properly
3971 -- if the attribute comes from source (if it was internally
3972 -- generated, we never need a constraint check).
3984 ------------------
3985 -- Storage_Pool --
3986 ------------------
3995 ------------------
3996 -- Storage_Size --
3997 ------------------
4001 -- Access type case, always go to the root type
4003 -- The case of access types results in a value of zero for the case
4004 -- where no storage size attribute clause has been given. If a
4005 -- storage size has been given, then the attribute is converted
4006 -- to a reference to the variable used to hold this value.
4017 New_Reference_To
4024 Name =>
4025 New_Reference_To
4026 (Find_Prim_Op
4029 Loc),
4032 New_Reference_To
4035 else
4041 -- For tasks, we retrieve the size directly from the TCB. The
4042 -- size may depend on a discriminant of the type, and therefore
4043 -- can be a per-object expression, so type-level information is
4044 -- not sufficient in general. There are four cases to consider:
4046 -- a) If the attribute appears within a task body, the designated
4047 -- TCB is obtained by a call to Self.
4049 -- b) If the prefix of the attribute is the name of a task object,
4050 -- the designated TCB is the one stored in the corresponding record.
4052 -- c) If the prefix is a task type, the size is obtained from the
4053 -- size variable created for each task type
4055 -- d) If no storage_size was specified for the type , there is no
4056 -- size variable, and the value is a system-specific default.
4058 else
4061 -- Storage_Size (Self)
4066 Name =>
4068 Parameter_Associations =>
4069 New_List (
4071 Name =>
4076 then
4077 -- Storage_Size (Rec (Obj).Size)
4082 Name =>
4084 Parameter_Associations =>
4085 New_List (
4087 Prefix =>
4088 Unchecked_Convert_To (
4091 Selector_Name =>
4096 -- Static storage size pragma given for type: retrieve value
4097 -- from its allocated storage variable.
4104 Parameter_Associations =>
4105 New_List (
4106 New_Reference_To (
4108 else
4109 -- Get system default
4114 Name =>
4115 New_Occurrence_Of (
4123 -----------------
4124 -- Stream_Size --
4125 -----------------
4130 begin
4131 -- If we have a Stream_Size clause for this type use it, otherwise
4132 -- the Stream_Size if the size of the type.
4135 Size :=
4136 UI_To_Int
4138 else
4146 ----------
4147 -- Succ --
4148 ----------
4150 -- 1. Deal with enumeration types with holes
4151 -- 2. For floating-point, generate call to attribute function
4152 -- 3. For other cases, deal with constraint checking
4155 declare
4158 begin
4160 -- For enumeration types with non-standard representations, we
4161 -- expand typ'Succ (x) into
4163 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
4165 -- If the representation is contiguous, we compute instead
4166 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
4170 then
4175 Left_Opnd =>
4178 Right_Opnd =>
4180 Name =>
4181 New_Reference_To
4184 Parameter_Associations =>
4185 New_List (
4188 Left_Opnd =>
4191 Right_Opnd =>
4194 else
4195 -- Add Boolean parameter True, to request program errror if
4196 -- we have a bad representation on our hands. Add False if
4197 -- checks are suppressed.
4202 Prefix =>
4203 New_Reference_To
4207 Left_Opnd =>
4209 Name =>
4210 New_Reference_To
4218 -- For floating-point, we transform 'Succ into a call to the Succ
4219 -- floating-point attribute function in Fat_xxx (xxx is root type)
4225 -- For modular types, nothing to do (no overflow, since wraps)
4230 -- For other types, if range checking is enabled, we must generate
4231 -- a check if overflow checking is enabled.
4238 ---------
4239 -- Tag --
4240 ---------
4242 -- Transforms X'Tag into a direct reference to the tag of X
4245 declare
4249 begin
4253 else
4266 -- For VMs we leave the type attribute unexpanded because
4267 -- there's not a dispatching table to reference.
4272 New_Reference_To
4277 -- (Ada 2005 (AI-251): The use of 'Tag in the sources always
4278 -- references the primary tag of the actual object. If 'Tag is
4279 -- applied to class-wide interface objects we generate code that
4280 -- displaces "this" to reference the base of the object.
4285 then
4286 -- Generate:
4287 -- (To_Tag_Ptr (Prefix'Address)).all
4289 -- Note that Prefix'Address is recursively expanded into a call
4290 -- to Base_Address (Obj.Tag)
4292 -- Not needed for VM targets, since all handled by the VM
4304 else
4308 Selector_Name =>
4314 ----------------
4315 -- Terminated --
4316 ----------------
4318 -- Transforms 'Terminated attribute into a call to Terminated function
4321 begin
4322 -- The prefix of Terminated is of a task interface class-wide type.
4323 -- Generate:
4325 -- terminated (Task_Id (Pref._disp_get_task_id));
4331 then
4334 Name =>
4338 Subtype_Mark =>
4340 Expression =>
4342 Prefix =>
4344 Selector_Name =>
4351 else
4359 ----------------
4360 -- To_Address --
4361 ----------------
4363 -- Transforms System'To_Address (X) into unchecked conversion
4364 -- from (integral) type of X to type address.
4372 ----------------
4373 -- Truncation --
4374 ----------------
4376 -- Transforms 'Truncation into a call to the floating-point attribute
4377 -- function Truncation in Fat_xxx (where xxx is the root type).
4378 -- Expansion is avoided for cases the back end can handle directly.
4385 -----------------------
4386 -- Unbiased_Rounding --
4387 -----------------------
4389 -- Transforms 'Unbiased_Rounding into a call to the floating-point
4390 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
4391 -- root type). Expansion is avoided for cases the back end can handle
4392 -- directly.
4399 -----------------
4400 -- UET_Address --
4401 -----------------
4407 begin
4412 Object_Definition =>
4415 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
4416 -- in normal external form.
4430 -- Set entity as internal to ensure proper Sprint output of its
4431 -- implicit importation.
4443 ---------------
4444 -- VADS_Size --
4445 ---------------
4447 -- The processing for VADS_Size is shared with Size
4449 ---------
4450 -- Val --
4451 ---------
4453 -- For enumeration types with a standard representation, and for all
4454 -- other types, Val is handled by the back end. For enumeration types
4455 -- with a non-standard representation we use the _Pos_To_Rep array that
4456 -- was created when the type was frozen.
4459 declare
4462 begin
4465 then
4467 declare
4471 Left_Opnd =>
4474 Right_Opnd =>
4478 begin
4482 Left_Opnd =>
4485 Right_Opnd =>
4487 Name =>
4488 New_Reference_To
4491 Rep_Node,
4495 else
4508 -----------
4509 -- Valid --
4510 -----------
4512 -- The code for valid is dependent on the particular types involved.
4513 -- See separate sections below for the generated code in each case.
4516 declare
4521 -- Save the validity checking mode. We always turn off validity
4522 -- checking during process of 'Valid since this is one place
4523 -- where we do not want the implicit validity checks to intefere
4524 -- with the explicit validity check that the programmer is doing.
4527 -- Build the code for a range test of the form
4528 -- Btyp!(Pref) >= Btyp!(Ptyp'First)
4529 -- and then
4530 -- Btyp!(Pref) <= Btyp!(Ptyp'Last)
4532 ---------------------
4533 -- Make_Range_Test --
4534 ---------------------
4537 begin
4538 return
4540 Left_Opnd =>
4542 Left_Opnd =>
4545 Right_Opnd =>
4551 Right_Opnd =>
4553 Left_Opnd =>
4557 Right_Opnd =>
4564 -- Start of processing for Attribute_Valid
4566 begin
4567 -- Turn off validity checks. We do not want any implicit validity
4568 -- checks to intefere with the explicit check from the attribute
4572 -- Floating-point case. This case is handled by the Valid attribute
4573 -- code in the floating-point attribute run-time library.
4576 declare
4580 begin
4581 -- For vax fpt types, call appropriate routine in special vax
4582 -- floating point unit. We do not have to worry about loads in
4583 -- this case, since these types have no signalling NaN's.
4588 -- The AAMP back end handles Valid for floating-point types
4595 -- Non VAX float case
4597 else
4600 -- If the floating-point object might be unaligned, we need
4601 -- to call the special routine Unaligned_Valid, which makes
4602 -- the needed copy, being careful not to load the value into
4603 -- any floating-point register. The argument in this case is
4604 -- obj'Address (see Unaligned_Valid routine in Fat_Gen).
4607 Expand_Fpt_Attribute
4609 New_List (
4614 -- In the normal case where we are sure the object is
4615 -- aligned, we generate a call to Valid, and the argument in
4616 -- this case is obj'Unrestricted_Access (after converting
4617 -- obj to the right floating-point type).
4619 else
4620 Expand_Fpt_Attribute
4622 New_List (
4629 -- One more task, we still need a range check. Required
4630 -- only if we have a constraint, since the Valid routine
4631 -- catches infinities properly (infinities are never valid).
4633 -- The way we do the range check is simply to create the
4634 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
4640 Right_Opnd =>
4647 -- Enumeration type with holes
4649 -- For enumeration types with holes, the Pos value constructed by
4650 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
4651 -- second argument of False returns minus one for an invalid value,
4652 -- and the non-negative pos value for a valid value, so the
4653 -- expansion of X'Valid is simply:
4655 -- type(X)'Pos (X) >= 0
4657 -- We can't quite generate it that way because of the requirement
4658 -- for the non-standard second argument of False in the resulting
4659 -- rep_to_pos call, so we have to explicitly create:
4661 -- _rep_to_pos (X, False) >= 0
4663 -- If we have an enumeration subtype, we also check that the
4664 -- value is in range:
4666 -- _rep_to_pos (X, False) >= 0
4667 -- and then
4668 -- (X >= type(X)'First and then type(X)'Last <= X)
4672 then
4673 Tst :=
4675 Left_Opnd =>
4677 Name =>
4678 New_Reference_To
4681 Pref,
4686 and then
4688 or else
4690 then
4691 -- The call to Make_Range_Test will create declarations
4692 -- that need a proper insertion point, but Pref is now
4693 -- attached to a node with no ancestor. Attach to tree
4694 -- even if it is to be rewritten below.
4698 Tst :=
4706 -- Fortran convention booleans
4708 -- For the very special case of Fortran convention booleans, the
4709 -- value is always valid, since it is an integer with the semantics
4710 -- that non-zero is true, and any value is permissible.
4714 then
4717 -- For biased representations, we will be doing an unchecked
4718 -- conversion without unbiasing the result. That means that the range
4719 -- test has to take this into account, and the proper form of the
4720 -- test is:
4722 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
4728 Left_Opnd =>
4730 Right_Opnd =>
4736 -- For all other scalar types, what we want logically is a
4737 -- range test:
4739 -- X in type(X)'First .. type(X)'Last
4741 -- But that's precisely what won't work because of possible
4742 -- unwanted optimization (and indeed the basic motivation for
4743 -- the Valid attribute is exactly that this test does not work!)
4744 -- What will work is:
4746 -- Btyp!(X) >= Btyp!(type(X)'First)
4747 -- and then
4748 -- Btyp!(X) <= Btyp!(type(X)'Last)
4750 -- where Btyp is an integer type large enough to cover the full
4751 -- range of possible stored values (i.e. it is chosen on the basis
4752 -- of the size of the type, not the range of the values). We write
4753 -- this as two tests, rather than a range check, so that static
4754 -- evaluation will easily remove either or both of the checks if
4755 -- they can be -statically determined to be true (this happens
4756 -- when the type of X is static and the range extends to the full
4757 -- range of stored values).
4759 -- Unsigned types. Note: it is safe to consider only whether the
4760 -- subtype is unsigned, since we will in that case be doing all
4761 -- unsigned comparisons based on the subtype range. Since we use the
4762 -- actual subtype object size, this is appropriate.
4764 -- For example, if we have
4766 -- subtype x is integer range 1 .. 200;
4767 -- for x'Object_Size use 8;
4769 -- Now the base type is signed, but objects of this type are bits
4770 -- unsigned, and doing an unsigned test of the range 1 to 200 is
4771 -- correct, even though a value greater than 127 looks signed to a
4772 -- signed comparison.
4777 else
4783 -- Signed types
4785 else
4788 else
4799 -----------
4800 -- Value --
4801 -----------
4803 -- Value attribute is handled in separate unti Exp_Imgv
4808 -----------------
4809 -- Value_Size --
4810 -----------------
4812 -- The processing for Value_Size shares the processing for Size
4814 -------------
4815 -- Version --
4816 -------------
4818 -- The processing for Version shares the processing for Body_Version
4820 ----------------
4821 -- Wide_Image --
4822 ----------------
4824 -- Wide_Image attribute is handled in separate unit Exp_Imgv
4829 ---------------------
4830 -- Wide_Wide_Image --
4831 ---------------------
4833 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
4838 ----------------
4839 -- Wide_Value --
4840 ----------------
4842 -- We expand typ'Wide_Value (X) into
4844 -- typ'Value
4845 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
4847 -- Wide_String_To_String is a runtime function that converts its wide
4848 -- string argument to String, converting any non-translatable characters
4849 -- into appropriate escape sequences. This preserves the required
4850 -- semantics of Wide_Value in all cases, and results in a very simple
4851 -- implementation approach.
4853 -- Note: for this approach to be fully standard compliant for the cases
4854 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
4855 -- method must cover the entire character range (e.g. UTF-8). But that
4856 -- is a reasonable requirement when dealing with encoded character
4857 -- sequences. Presumably if one of the restrictive encoding mechanisms
4858 -- is in use such as Shift-JIS, then characters that cannot be
4859 -- represented using this encoding will not appear in any case.
4862 begin
4870 Name =>
4881 ---------------------
4882 -- Wide_Wide_Value --
4883 ---------------------
4885 -- We expand typ'Wide_Value_Value (X) into
4887 -- typ'Value
4888 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
4890 -- Wide_Wide_String_To_String is a runtime function that converts its
4891 -- wide string argument to String, converting any non-translatable
4892 -- characters into appropriate escape sequences. This preserves the
4893 -- required semantics of Wide_Wide_Value in all cases, and results in a
4894 -- very simple implementation approach.
4896 -- It's not quite right where typ = Wide_Wide_Character, because the
4897 -- encoding method may not cover the whole character type ???
4900 begin
4908 Name =>
4919 ---------------------
4920 -- Wide_Wide_Width --
4921 ---------------------
4923 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
4928 ----------------
4929 -- Wide_Width --
4930 ----------------
4932 -- Wide_Width attribute is handled in separate unit Exp_Imgv
4937 -----------
4938 -- Width --
4939 -----------
4941 -- Width attribute is handled in separate unit Exp_Imgv
4946 -----------
4947 -- Write --
4948 -----------
4959 begin
4960 -- If no underlying type, we have an error that will be diagnosed
4961 -- elsewhere, so here we just completely ignore the expansion.
4967 -- The simple case, if there is a TSS for Write, just call it
4974 else
4975 -- If there is a Stream_Convert pragma, use it, we rewrite
4977 -- sourcetyp'Output (stream, Item)
4979 -- as
4981 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4983 -- where strmwrite is the given Write function that converts an
4984 -- argument of type sourcetyp or a type acctyp, from which it is
4985 -- derived to type strmtyp. The conversion to acttyp is required
4986 -- for the derived case.
4991 Arg3 :=
5010 -- For elementary types, we call the W_xxx routine directly
5017 -- Array type case
5023 -- Tagged type case, use the primitive Write function. Note that
5024 -- this will dispatch in the class-wide case which is what we want
5029 -- All other record type cases, including protected records.
5030 -- The latter only arise for expander generated code for
5031 -- handling shared passive partition access.
5033 else
5034 pragma Assert
5037 -- Ada 2005 (AI-216): Program_Error is raised when executing
5038 -- the default implementation of the Write attribute of an
5039 -- Unchecked_Union type. However, if the 'Write reference is
5040 -- within the generated Output stream procedure, Write outputs
5041 -- the components, and the default values of the discriminant
5042 -- are streamed by the Output procedure itself.
5046 then
5053 and then Present
5055 then
5056 Build_Mutable_Record_Write_Procedure
5058 else
5059 Build_Record_Write_Procedure
5067 -- If we fall through, Pname is the procedure to be called
5072 -- Component_Size is handled by the back end, unless the component size
5073 -- is known at compile time, which is always true in the packed array
5074 -- case. It is important that the packed array case is handled in the
5075 -- front end (see Eval_Attribute) since the back end would otherwise get
5076 -- confused by the equivalent packed array type.
5081 -- The following attributes are handled by the back end (except that
5082 -- static cases have already been evaluated during semantic processing,
5083 -- but in any case the back end should not count on this). The one bit
5084 -- of special processing required is that these attributes typically
5085 -- generate conditionals in the code, so we need to check the relevant
5086 -- restriction.
5088 when Attribute_Max |
5089 Attribute_Min =>
5092 -- The following attributes are handled by the back end (except that
5093 -- static cases have already been evaluated during semantic processing,
5094 -- but in any case the back end should not count on this).
5096 -- The back end also handles the non-class-wide cases of Size
5098 when Attribute_Bit_Order |
5099 Attribute_Code_Address |
5100 Attribute_Definite |
5101 Attribute_Null_Parameter |
5102 Attribute_Passed_By_Reference |
5103 Attribute_Pool_Address =>
5106 -- The following attributes are also handled by the back end, but return
5107 -- a universal integer result, so may need a conversion for checking
5108 -- that the result is in range.
5110 when Attribute_Aft |
5111 Attribute_Bit |
5112 Attribute_Max_Size_In_Storage_Elements
5113 =>
5116 -- The following attributes should not appear at this stage, since they
5117 -- have already been handled by the analyzer (and properly rewritten
5118 -- with corresponding values or entities to represent the right values)
5120 when Attribute_Abort_Signal |
5121 Attribute_Address_Size |
5122 Attribute_Base |
5123 Attribute_Class |
5124 Attribute_Default_Bit_Order |
5125 Attribute_Delta |
5126 Attribute_Denorm |
5127 Attribute_Digits |
5128 Attribute_Emax |
5129 Attribute_Enabled |
5130 Attribute_Epsilon |
5131 Attribute_Fast_Math |
5132 Attribute_Has_Access_Values |
5133 Attribute_Has_Discriminants |
5134 Attribute_Has_Tagged_Values |
5135 Attribute_Large |
5136 Attribute_Machine_Emax |
5137 Attribute_Machine_Emin |
5138 Attribute_Machine_Mantissa |
5139 Attribute_Machine_Overflows |
5140 Attribute_Machine_Radix |
5141 Attribute_Machine_Rounds |
5142 Attribute_Maximum_Alignment |
5143 Attribute_Model_Emin |
5144 Attribute_Model_Epsilon |
5145 Attribute_Model_Mantissa |
5146 Attribute_Model_Small |
5147 Attribute_Modulus |
5148 Attribute_Partition_ID |
5149 Attribute_Range |
5150 Attribute_Safe_Emax |
5151 Attribute_Safe_First |
5152 Attribute_Safe_Large |
5153 Attribute_Safe_Last |
5154 Attribute_Safe_Small |
5155 Attribute_Scale |
5156 Attribute_Signed_Zeros |
5157 Attribute_Small |
5158 Attribute_Storage_Unit |
5159 Attribute_Stub_Type |
5160 Attribute_Target_Name |
5161 Attribute_Type_Class |
5162 Attribute_Unconstrained_Array |
5163 Attribute_Universal_Literal_String |
5164 Attribute_Wchar_T_Size |
5165 Attribute_Word_Size =>
5169 -- The Asm_Input and Asm_Output attributes are not expanded at this
5170 -- stage, but will be eliminated in the expansion of the Asm call, see
5171 -- Exp_Intr for details. So the back end will never see these either.
5173 when Attribute_Asm_Input |
5174 Attribute_Asm_Output =>
5180 exception
5185 ----------------------
5186 -- Expand_Pred_Succ --
5187 ----------------------
5189 -- For typ'Pred (exp), we generate the check
5191 -- [constraint_error when exp = typ'Base'First]
5193 -- Similarly, for typ'Succ (exp), we generate the check
5195 -- [constraint_error when exp = typ'Base'Last]
5197 -- These checks are not generated for modular types, since the proper
5198 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
5204 begin
5207 else
5213 Condition =>
5215 Left_Opnd =>
5217 Right_Opnd =>
5219 Prefix =>
5225 -------------------
5226 -- Find_Fat_Info --
5227 -------------------
5229 procedure Find_Fat_Info
5233 is
5238 begin
5239 -- If the base type is VAX float, then get appropriate VAX float type
5259 -- If root type is VAX float, this is the case where the library has
5260 -- been recompiled in VAX float mode, and we have an IEEE float type.
5261 -- This is when we use the special IEEE Fat packages.
5277 -- If neither the base type nor the root type is VAX_Float then VAX
5278 -- float is out of the picture, and we can just use the root type.
5280 else
5295 -- Universal real (which is its own root type) is treated as being
5296 -- equivalent to Standard.Long_Long_Float, since it is defined to
5297 -- have the same precision as the longest Float type.
5303 else
5309 ----------------------------
5310 -- Find_Stream_Subprogram --
5311 ----------------------------
5313 function Find_Stream_Subprogram
5316 is
5319 begin
5324 -- Stream attributes for strings are expanded into library calls. The
5325 -- following checks are disabled when the run-time is not available or
5326 -- when compiling predefined types due to bootstrap issues. As a result,
5327 -- the compiler will generate in-place stream routines for string types
5328 -- that appear in GNAT's library, but will generate calls via rtsfind
5329 -- to library routines for user code.
5330 -- ??? For now, disable this code for JVM, since this generates a
5331 -- VerifyError exception at run-time on e.g. c330001.
5332 -- This is disabled for AAMP, to avoid making dependences on files not
5333 -- supported in the AAMP library (such as s-fileio.adb).
5336 and then not AAMP_On_Target
5337 and then
5339 then
5341 -- String as defined in package Ada
5357 -- Wide_String as defined in package Ada
5373 -- Wide_Wide_String as defined in package Ada
5393 then
5395 else
5400 -----------------------
5401 -- Get_Index_Subtype --
5402 -----------------------
5409 begin
5416 else
5429 -------------------------------
5430 -- Get_Stream_Convert_Pragma --
5431 -------------------------------
5437 begin
5438 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
5439 -- that a stream convert pragma for a tagged type is not inherited from
5440 -- its parent. Probably what is wrong here is that it is basically
5441 -- incorrect to consider a stream convert pragma to be a representation
5442 -- pragma at all ???
5448 then
5449 -- For tagged types this pragma is not inherited, so we
5450 -- must verify that it is defined for the given type and
5451 -- not an ancestor.
5453 Typ :=
5459 then
5470 ---------------------------------
5471 -- Is_Constrained_Packed_Array --
5472 ---------------------------------
5477 begin
5487 ----------------------------------------
5488 -- Is_Inline_Floating_Point_Attribute --
5489 ----------------------------------------
5494 begin
5497 then
5501 -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
5502 -- required back end support has not been implemented yet ???