| blob | e4d45d5f09df0ea945e7b60011c6aeb036e8b0ba |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ I N T R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
63 -----------------------
64 -- Local Subprograms --
65 -----------------------
68 -- Expand a call to an intrinsic arithmetic operator when the operand
69 -- types or sizes are not identical.
72 -- Expand a call to the intrinsic Is_Negative function
75 -- Expand a call to an instantiation of Generic_Dispatching_Constructor
76 -- into a dispatching call to the actual subprogram associated with the
77 -- Constructor formal subprogram, passing it the Parameters actual of
78 -- the call to the instantiation and dispatching based on call's Tag
79 -- parameter.
82 -- Expand a call to Exception_Information/Message/Name. The first
83 -- parameter, N, is the node for the function call, and Ent is the
84 -- entity for the corresponding routine in the Ada.Exceptions package.
87 -- Expand a call to Import_Address/Longest_Integer/Value. The parameter
88 -- N is the node for the function call.
91 -- Expand an intrinsic shift operation, N and E are from the call to
92 -- Expand_Intrinsic_Call (call node and subprogram spec entity) and
93 -- K is the kind for the shift node
96 -- Expand a call to an instantiation of Unchecked_Conversion into a node
97 -- N_Unchecked_Type_Conversion.
100 -- Expand a call to an instantiation of Unchecked_Deallocation into a node
101 -- N_Free_Statement and appropriate context.
105 -- Expand a call to corresponding function, declared in an instance of
106 -- System.Address_To_Access_Conversions.
109 -- Rewrite the node as the appropriate string literal or positive
110 -- constant. Nam is the name of one of the intrinsics declared in
111 -- GNAT.Source_Info; see g-souinf.ads for documentation of these
112 -- intrinsics.
115 -- Recursive procedure to construct string for qualified name of enclosing
116 -- program unit. The qualification stops at an enclosing scope has no
117 -- source name (block or loop). If entity is a subprogram instance, skip
118 -- enclosing wrapper package. The name is appended to Buf.
120 ---------------------
121 -- Add_Source_Info --
122 ---------------------
124 procedure Add_Source_Info
128 is
129 begin
142 -- Skip enclosing blocks to reach enclosing unit
144 declare
146 begin
152 -- Ent now points to the relevant defining entity
161 declare
174 begin
175 -- Reformat ISO date into MMM DD YYYY (__DATE__) format
192 -----------------------
193 -- Append_Entity_Name --
194 -----------------------
200 -- Inner recursive routine, keep outer routine nonrecursive to ease
201 -- debugging when we get strange results from this routine.
203 -----------
204 -- Inner --
205 -----------
208 begin
209 -- If entity has an internal name, skip by it, and print its scope.
210 -- Note that we strip a final R from the name before the test; this
211 -- is needed for some cases of instantiations.
213 declare
216 begin
229 -- Just print entity name if its scope is at the outer level
234 -- If scope comes from source, write scope and entity
240 -- If in wrapper package skip past it
246 -- Otherwise nothing to output (happens in unnamed block statements)
248 else
252 -- Output the name
254 declare
257 begin
260 -- Remove trailing upper-case letters from the name (useful for
261 -- dealing with some cases of internal names generated in the case
262 -- of references from within a generic).
266 loop
270 -- Adjust casing appropriately (gets name from source if possible)
277 -- Start of processing for Append_Entity_Name
279 begin
284 ---------------------------------
285 -- Expand_Binary_Operator_Call --
286 ---------------------------------
296 -- Maximum of operand sizes
298 begin
299 -- Nothing to do if the operands have the same modular type
303 then
307 -- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64
311 else
315 -- Copy operator node, and reset type and entity fields, for
316 -- subsequent reanalysis.
332 -- Convert operands to large enough intermediate type
339 -- Analyze and resolve result formed by conversion to target type
345 -----------------------------------------
346 -- Expand_Dispatching_Constructor_Call --
347 -----------------------------------------
349 -- Transform a call to an instantiation of Generic_Dispatching_Constructor
350 -- of the form:
352 -- GDC_Instance (The_Tag, Parameters'Access)
354 -- to a class-wide conversion of a dispatching call to the actual
355 -- associated with the formal subprogram Construct, designating The_Tag
356 -- as the controlling tag of the call:
358 -- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag
360 -- which will eventually be expanded to the following:
362 -- T'Class (The_Tag.all (Construct'Actual'Index).all (Params))
364 -- A class-wide membership test is also generated, preceding the call, to
365 -- ensure that the controlling tag denotes a type in T'Class.
379 begin
380 -- Remove side effects from tag argument early, before rewriting
381 -- the dispatching constructor call, as Remove_Side_Effects relies
382 -- on Tag_Arg's Parent link properly attached to the tree (once the
383 -- call is rewritten, the Parent is inconsistent as it points to the
384 -- rewritten node, which is not the syntactic parent of the Tag_Arg
385 -- anymore).
389 -- Check that we have a proper tag
401 -- Check that it is not the tag of an abstract type
406 Name =>
414 -- The subprogram is the third actual in the instantiation, and is
415 -- retrieved from the corresponding renaming declaration. However,
416 -- freeze nodes may appear before, so we retrieve the declaration
417 -- with an explicit loop.
427 -- Check that the accessibility level of the tag is no deeper than that
428 -- of the constructor function.
432 Condition =>
434 Left_Opnd =>
436 Right_Opnd =>
445 -- If the result type is not known to be a parent of Tag_Arg then we
446 -- need to locate the tag of the secondary dispatch table.
450 and then Tagged_Type_Expansion
451 then
452 -- Obtain the reference to the Ada.Tags service before generating
453 -- the Object_Declaration node to ensure that if this service is
454 -- not available in the runtime then we generate a clear error.
456 declare
460 begin
463 -- The tag is the first entry in the dispatch table of the
464 -- return type of the constructor.
466 Iface_Tag :=
469 Object_Definition =>
471 Expression =>
476 New_Occurrence_Of
479 Loc))));
485 -- Create the call to the actual Constructor function
487 Cnstr_Call :=
492 -- Establish its controlling tag from the tag passed to the instance
493 -- The tag may be given by a function call, in which case a temporary
494 -- should be generated now, to prevent out-of-order insertions during
495 -- the expansion of that call when stack-checking is enabled.
500 else
505 -- Rewrite and analyze the call to the instance as a class-wide
506 -- conversion of the call to the actual constructor.
510 -- Do not generate a run-time check on the built object if tag
511 -- checks are suppressed for the result type or tagged type expansion
512 -- is disabled.
515 or else not Tagged_Type_Expansion
516 then
519 -- Generate a class-wide membership test to ensure that the call's tag
520 -- argument denotes a type within the class. We must keep separate the
521 -- case in which the Result_Type of the constructor function is a tagged
522 -- type from the case in which it is an abstract interface because the
523 -- run-time subprogram required to check these cases differ (and have
524 -- one difference in their parameters profile).
526 -- Call CW_Membership if the Result_Type is a tagged type to look for
527 -- the tag in the table of ancestor tags.
530 declare
534 begin
537 Typ_Tag_Node =>
538 New_Occurrence_Of (
546 Condition =>
548 Then_Statements =>
553 -- Call IW_Membership test if the Result_Type is an abstract interface
554 -- to look for the tag in the table of interface tags.
556 else
559 Condition =>
568 New_Occurrence_Of (
571 Then_Statements =>
572 New_List (
580 ---------------------------
581 -- Expand_Exception_Call --
582 ---------------------------
584 -- If the function call is not within an exception handler, then the call
585 -- is replaced by a null string. Otherwise the appropriate routine in
586 -- Ada.Exceptions is called passing the choice parameter specification
587 -- from the enclosing handler. If the enclosing handler lacks a choice
588 -- parameter, then one is supplied.
595 begin
596 -- Climb up parents to see if we are in exception handler
599 loop
600 -- Case of not in exception handler, replace by null string
608 -- Case of in exception handler
612 -- Handler cannot be used for a local raise, and furthermore, this
613 -- is a violation of the No_Exception_Propagation restriction.
618 -- If no choice parameter present, then put one there. Note that
619 -- we do not need to put it on the entity chain, since no one will
620 -- be referencing it by normal visibility methods.
637 -- Keep climbing
639 else
647 ------------------------
648 -- Expand_Import_Call --
649 ------------------------
651 -- The function call must have a static string as its argument. We create
652 -- a dummy variable which uses this string as the external name in an
653 -- Import pragma. The result is then obtained as the address of this
654 -- dummy variable, converted to the appropriate target type.
662 begin
666 Object_Definition =>
691 ---------------------------
692 -- Expand_Intrinsic_Call --
693 ---------------------------
698 begin
699 -- If an external name is specified for the intrinsic, it is handled
700 -- by the back-end: leave the call node unchanged for now.
706 -- If the intrinsic subprogram is generic, gets its original name
710 then
712 else
735 Name_Import_Largest_Value,
736 Name_Import_Value)
737 then
771 Name_Line,
772 Name_Source_Location,
773 Name_Enclosing_Entity,
774 Name_Compilation_ISO_Date,
775 Name_Compilation_Date,
776 Name_Compilation_Time)
777 then
780 -- If we have a renaming, expand the call to the original operation,
781 -- which must itself be intrinsic, since renaming requires matching
782 -- conventions and this has already been checked.
790 -- The only other case is where an external name was specified, since
791 -- this is the only way that an otherwise unrecognized name could
792 -- escape the checking in Sem_Prag. Nothing needs to be done in such
793 -- a case, since we pass such a call to the back end unchanged.
795 else
800 ------------------------
801 -- Expand_Is_Negative --
802 ------------------------
808 begin
810 -- We replace the function call by the following expression
812 -- if Opnd < 0.0 then
813 -- True
814 -- else
815 -- if Opnd > 0.0 then
816 -- False;
817 -- else
818 -- Float_Unsigned!(Float (Opnd)) /= 0
819 -- end if;
820 -- end if;
840 Left_Opnd =>
841 Unchecked_Convert_To
843 Convert_To
846 Right_Opnd =>
852 ------------------
853 -- Expand_Shift --
854 ------------------
856 -- This procedure is used to convert a call to a shift function to the
857 -- corresponding operator node. This conversion is not done by the usual
858 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to
859 -- operator nodes, because shifts are not predefined operators.
861 -- As a result, whenever a shift is used in the source program, it will
862 -- remain as a call until converted by this routine to the operator node
863 -- form which the back end is expecting to see.
865 -- Note: it is possible for the expander to generate shift operator nodes
866 -- directly, which will be analyzed in the normal manner by calling Analyze
867 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
879 begin
888 then
894 -- Note that we don't call Analyze and Resolve on this node, because
895 -- it already got analyzed and resolved when it was a function call.
901 -- However, we do call the expander, so that the expansion for
902 -- rotates and shift_right_arithmetic happens if Modify_Tree_For_C
903 -- is set.
909 else
910 -- If the context type is not the type of the operator, it is an
911 -- inherited operator for a derived type. Wrap the node in a
912 -- conversion so that it is type-consistent for possible further
913 -- expansion (e.g. within a lock-free protected type).
919 -- Analyze and resolve result formed by conversion to target type
925 ------------------------
926 -- Expand_Source_Info --
927 ------------------------
931 begin
932 -- Integer cases
940 -- String cases
942 else
943 declare
945 begin
955 ---------------------------
956 -- Expand_Unc_Conversion --
957 ---------------------------
965 begin
966 -- Rewrite as unchecked conversion node. Note that we must convert
967 -- the operand to the formal type of the input parameter of the
968 -- function, so that the resulting N_Unchecked_Type_Conversion
969 -- call indicates the correct types for Gigi.
971 -- Right now, we only do this if a scalar type is involved. It is
972 -- not clear if it is needed in other cases. If we do attempt to
973 -- do the conversion unconditionally, it crashes 3411-018. To be
974 -- investigated further ???
985 -- The instantiation of Unchecked_Conversion creates a wrapper package,
986 -- and the target type is declared as a subtype of the actual. Recover
987 -- the actual, which is the subtype indic. in the subtype declaration
988 -- for the target type. This is semantically correct, and avoids
989 -- anomalies with access subtypes. For entities, leave type as is.
991 -- We do the analysis here, because we do not want the compiler
992 -- to try to optimize or otherwise reorganize the unchecked
993 -- conversion node.
1004 Ttyp :=
1006 else
1019 -----------------------------
1020 -- Expand_Unc_Deallocation --
1021 -----------------------------
1034 -- This captures whether we know the argument to be non-null so that
1035 -- we can avoid the test. The reason that we need to capture this is
1036 -- that we analyze some generated statements before properly attaching
1037 -- them to the tree, and that can disturb current value settings.
1054 begin
1055 -- Nothing to do if we know the argument is null
1061 -- Processing for pointer to controlled types. Generate:
1063 -- Abrt : constant Boolean := ...;
1064 -- Ex : Exception_Occurrence;
1065 -- Raised : Boolean := False;
1067 -- begin
1068 -- Abort_Defer;
1070 -- begin
1071 -- [Deep_]Finalize (Obj_Ref);
1073 -- exception
1074 -- when others =>
1075 -- if not Raised then
1076 -- Raised := True;
1077 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
1078 -- end;
1079 -- at end
1080 -- Abort_Undefer_Direct;
1081 -- end;
1083 -- Depending on whether exception propagation is enabled and/or aborts
1084 -- are allowed, the generated code may lack block statements.
1087 Obj_Ref :=
1091 -- If the designated type is tagged, the finalization call must
1092 -- dispatch because the designated type may not be the actual type
1093 -- of the object. If the type is synchronized, the deallocation
1094 -- applies to the corresponding record type.
1098 Obj_Ref :=
1099 Unchecked_Convert_To
1101 Obj_Ref);
1104 Obj_Ref :=
1108 -- Otherwise the designated type is untagged. Set the type of the
1109 -- dereference explicitly to force a conversion when needed given
1110 -- that [Deep_]Finalize may be inherited from a parent type.
1112 else
1116 -- Generate:
1117 -- [Deep_]Finalize (Obj_Ref);
1121 -- Generate:
1122 -- Abrt : constant Boolean := ...;
1123 -- Ex : Exception_Occurrence;
1124 -- Raised : Boolean := False;
1126 -- begin
1127 -- <Fin_Call>
1129 -- exception
1130 -- when others =>
1131 -- if not Raised then
1132 -- Raised := True;
1133 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
1134 -- end;
1139 Fin_Blk :=
1141 Handled_Statement_Sequence =>
1147 -- Otherwise exception propagation is not allowed
1149 else
1153 -- The finalization action must be protected by an abort defer and
1154 -- undefer pair when aborts are allowed. Generate:
1156 -- begin
1157 -- Abort_Defer;
1158 -- <Fin_Blk>
1159 -- at end
1160 -- Abort_Undefer_Direct;
1161 -- end;
1166 Abrt_HSS :=
1170 Fin_Blk),
1173 Abrt_Blk :=
1180 -- Present the Abort_Undefer_Direct function to the backend so
1181 -- that it can inline the call to the function.
1185 -- Otherwise aborts are not allowed
1187 else
1194 -- For a task type, call Free_Task before freeing the ATCB. We used to
1195 -- detect the case of Abort followed by a Free here, because the Free
1196 -- wouldn't actually free if it happens before the aborted task actually
1197 -- terminates. The warning was removed, because Free now works properly
1198 -- (the task will be freed once it terminates).
1204 -- For composite types that contain tasks, recurse over the structure
1205 -- to build the selectors for the task subcomponents.
1216 -- Same for simple protected types. Eventually call Finalize_Protection
1217 -- before freeing the PO for each protected component.
1232 -- Normal processing for non-controlled types. The argument to free is
1233 -- a renaming rather than a constant to ensure that the original context
1234 -- is always set to null after the deallocation takes place.
1241 -- Attach to tree before analysis of generated subtypes below
1245 -- Deal with storage pool
1249 -- Freeing the secondary stack is meaningless
1254 -- If the pool object is of a simple storage pool type, then attempt
1255 -- to locate the type's Deallocate procedure, if any, and set the
1256 -- free operation's procedure to call. If the type doesn't have a
1257 -- Deallocate (which is allowed), then the actual will simply be set
1258 -- to null.
1260 elsif Present
1262 then
1263 declare
1267 begin
1273 then
1276 else
1282 -- Case of a class-wide pool type: make a dispatching call to
1283 -- Deallocate through the class-wide Deallocate_Any.
1288 -- Case of a specific pool type: make a statically bound call
1290 else
1291 Set_Procedure_To_Call
1298 -- For all cases of a Deallocate call, the back-end needs to be able
1299 -- to compute the size of the object being freed. This may require
1300 -- some adjustments for objects of dynamic size.
1301 --
1302 -- If the type is class wide, we generate an implicit type with the
1303 -- right dynamic size, so that the deallocate call gets the right
1304 -- size parameter computed by GIGI. Same for an access to
1305 -- unconstrained packed array.
1308 or else
1312 then
1313 declare
1320 begin
1321 -- Perform minor decoration as it is needed by the side effect
1322 -- removal mechanism.
1331 else
1339 -- Force freezing at the point of the dereference. For the
1340 -- class wide case, this avoids having the subtype frozen
1341 -- before the equivalent type.
1350 -- Ada 2005 (AI-251): In case of abstract interface type we must
1351 -- displace the pointer to reference the base of the object to
1352 -- deallocate its memory, unless we're targetting a VM, in which case
1353 -- no special processing is required.
1355 -- Generate:
1356 -- free (Base_Address (Obj_Ptr))
1359 and then Tagged_Type_Expansion
1360 then
1364 Name =>
1369 -- Generate:
1370 -- free (Obj_Ptr)
1372 else
1376 -- Only remaining step is to set result to null, or generate a raise of
1377 -- Constraint_Error if the target object is "not null".
1384 else
1385 declare
1387 begin
1396 -- Generate a test of whether any earlier finalization raised an
1397 -- exception, and in that case raise Program_Error with the previous
1398 -- exception occurrence.
1400 -- Generate:
1401 -- if Raised and then not Abrt then
1402 -- raise Program_Error; -- for restricted RTS
1403 -- <or>
1404 -- Raise_From_Controlled_Operation (E); -- all other cases
1405 -- end if;
1411 -- If we know the argument is non-null, then make a block statement
1412 -- that contains the required statements, no need for a test.
1415 Gen_Code :=
1417 Handled_Statement_Sequence =>
1421 -- If the argument may be null, wrap the statements inside an IF that
1422 -- does an explicit test to exclude the null case.
1424 else
1425 Gen_Code :=
1427 Condition =>
1434 -- Rewrite the call
1440 -----------------------
1441 -- Expand_To_Address --
1442 -----------------------
1449 begin
1468 -----------------------
1469 -- Expand_To_Pointer --
1470 -----------------------
1475 begin