| blob | fde0617aa834cbe8ba6b1f8afaf5d61d7fbbdd8a |
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-2016, 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.
328 -- Convert operands to large enough intermediate type
335 -- Analyze and resolve result formed by conversion to target type
341 -----------------------------------------
342 -- Expand_Dispatching_Constructor_Call --
343 -----------------------------------------
345 -- Transform a call to an instantiation of Generic_Dispatching_Constructor
346 -- of the form:
348 -- GDC_Instance (The_Tag, Parameters'Access)
350 -- to a class-wide conversion of a dispatching call to the actual
351 -- associated with the formal subprogram Construct, designating The_Tag
352 -- as the controlling tag of the call:
354 -- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag
356 -- which will eventually be expanded to the following:
358 -- T'Class (The_Tag.all (Construct'Actual'Index).all (Params))
360 -- A class-wide membership test is also generated, preceding the call, to
361 -- ensure that the controlling tag denotes a type in T'Class.
375 begin
376 -- Remove side effects from tag argument early, before rewriting
377 -- the dispatching constructor call, as Remove_Side_Effects relies
378 -- on Tag_Arg's Parent link properly attached to the tree (once the
379 -- call is rewritten, the Parent is inconsistent as it points to the
380 -- rewritten node, which is not the syntactic parent of the Tag_Arg
381 -- anymore).
385 -- Check that we have a proper tag
397 -- Check that it is not the tag of an abstract type
402 Name =>
410 -- The subprogram is the third actual in the instantiation, and is
411 -- retrieved from the corresponding renaming declaration. However,
412 -- freeze nodes may appear before, so we retrieve the declaration
413 -- with an explicit loop.
423 -- Check that the accessibility level of the tag is no deeper than that
424 -- of the constructor function (unless CodePeer_Mode)
429 Condition =>
431 Left_Opnd =>
433 Right_Opnd =>
443 -- If the result type is not known to be a parent of Tag_Arg then we
444 -- need to locate the tag of the secondary dispatch table.
448 and then Tagged_Type_Expansion
449 then
450 -- Obtain the reference to the Ada.Tags service before generating
451 -- the Object_Declaration node to ensure that if this service is
452 -- not available in the runtime then we generate a clear error.
454 declare
458 begin
461 -- The tag is the first entry in the dispatch table of the
462 -- return type of the constructor.
464 Iface_Tag :=
467 Object_Definition =>
469 Expression =>
474 New_Occurrence_Of
477 Loc))));
483 -- Create the call to the actual Constructor function
485 Cnstr_Call :=
490 -- Establish its controlling tag from the tag passed to the instance
491 -- The tag may be given by a function call, in which case a temporary
492 -- should be generated now, to prevent out-of-order insertions during
493 -- the expansion of that call when stack-checking is enabled.
498 else
503 -- Rewrite and analyze the call to the instance as a class-wide
504 -- conversion of the call to the actual constructor.
508 -- Do not generate a run-time check on the built object if tag
509 -- checks are suppressed for the result type or tagged type expansion
510 -- is disabled or if CodePeer_Mode.
513 or else not Tagged_Type_Expansion
514 or else CodePeer_Mode
515 then
518 -- Generate a class-wide membership test to ensure that the call's tag
519 -- argument denotes a type within the class. We must keep separate the
520 -- case in which the Result_Type of the constructor function is a tagged
521 -- type from the case in which it is an abstract interface because the
522 -- run-time subprogram required to check these cases differ (and have
523 -- one difference in their parameters profile).
525 -- Call CW_Membership if the Result_Type is a tagged type to look for
526 -- the tag in the table of ancestor tags.
529 declare
533 begin
536 Typ_Tag_Node =>
537 New_Occurrence_Of (
545 Condition =>
547 Then_Statements =>
552 -- Call IW_Membership test if the Result_Type is an abstract interface
553 -- to look for the tag in the table of interface tags.
555 else
558 Condition =>
567 New_Occurrence_Of (
570 Then_Statements =>
571 New_List (
579 ---------------------------
580 -- Expand_Exception_Call --
581 ---------------------------
583 -- If the function call is not within an exception handler, then the call
584 -- is replaced by a null string. Otherwise the appropriate routine in
585 -- Ada.Exceptions is called passing the choice parameter specification
586 -- from the enclosing handler. If the enclosing handler lacks a choice
587 -- parameter, then one is supplied.
594 begin
595 -- Climb up parents to see if we are in exception handler
598 loop
599 -- Case of not in exception handler, replace by null string
607 -- Case of in exception handler
611 -- Handler cannot be used for a local raise, and furthermore, this
612 -- is a violation of the No_Exception_Propagation restriction.
617 -- If no choice parameter present, then put one there. Note that
618 -- we do not need to put it on the entity chain, since no one will
619 -- be referencing it by normal visibility methods.
636 -- Keep climbing
638 else
646 ------------------------
647 -- Expand_Import_Call --
648 ------------------------
650 -- The function call must have a static string as its argument. We create
651 -- a dummy variable which uses this string as the external name in an
652 -- Import pragma. The result is then obtained as the address of this
653 -- dummy variable, converted to the appropriate target type.
661 begin
665 Object_Definition =>
690 ---------------------------
691 -- Expand_Intrinsic_Call --
692 ---------------------------
697 begin
698 -- If an external name is specified for the intrinsic, it is handled
699 -- by the back-end: leave the call node unchanged for now.
705 -- If the intrinsic subprogram is generic, gets its original name
709 then
711 else
734 Name_Import_Largest_Value,
735 Name_Import_Value)
736 then
770 Name_Line,
771 Name_Source_Location,
772 Name_Enclosing_Entity,
773 Name_Compilation_ISO_Date,
774 Name_Compilation_Date,
775 Name_Compilation_Time)
776 then
779 -- If we have a renaming, expand the call to the original operation,
780 -- which must itself be intrinsic, since renaming requires matching
781 -- conventions and this has already been checked.
789 -- The only other case is where an external name was specified, since
790 -- this is the only way that an otherwise unrecognized name could
791 -- escape the checking in Sem_Prag. Nothing needs to be done in such
792 -- a case, since we pass such a call to the back end unchanged.
794 else
799 ------------------------
800 -- Expand_Is_Negative --
801 ------------------------
807 begin
809 -- We replace the function call by the following expression
811 -- if Opnd < 0.0 then
812 -- True
813 -- else
814 -- if Opnd > 0.0 then
815 -- False;
816 -- else
817 -- Float_Unsigned!(Float (Opnd)) /= 0
818 -- end if;
819 -- end if;
839 Left_Opnd =>
840 Unchecked_Convert_To
842 Convert_To
845 Right_Opnd =>
851 ------------------
852 -- Expand_Shift --
853 ------------------
855 -- This procedure is used to convert a call to a shift function to the
856 -- corresponding operator node. This conversion is not done by the usual
857 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to
858 -- operator nodes, because shifts are not predefined operators.
860 -- As a result, whenever a shift is used in the source program, it will
861 -- remain as a call until converted by this routine to the operator node
862 -- form which the back end is expecting to see.
864 -- Note: it is possible for the expander to generate shift operator nodes
865 -- directly, which will be analyzed in the normal manner by calling Analyze
866 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
878 begin
887 then
893 -- Note that we don't call Analyze and Resolve on this node, because
894 -- it already got analyzed and resolved when it was a function call.
900 -- However, we do call the expander, so that the expansion for
901 -- rotates and shift_right_arithmetic happens if Modify_Tree_For_C
902 -- is set.
908 else
909 -- If the context type is not the type of the operator, it is an
910 -- inherited operator for a derived type. Wrap the node in a
911 -- conversion so that it is type-consistent for possible further
912 -- expansion (e.g. within a lock-free protected type).
918 -- Analyze and resolve result formed by conversion to target type
924 ------------------------
925 -- Expand_Source_Info --
926 ------------------------
930 begin
931 -- Integer cases
939 -- String cases
941 else
942 declare
944 begin
954 ---------------------------
955 -- Expand_Unc_Conversion --
956 ---------------------------
964 begin
965 -- Rewrite as unchecked conversion node. Note that we must convert
966 -- the operand to the formal type of the input parameter of the
967 -- function, so that the resulting N_Unchecked_Type_Conversion
968 -- call indicates the correct types for Gigi.
970 -- Right now, we only do this if a scalar type is involved. It is
971 -- not clear if it is needed in other cases. If we do attempt to
972 -- do the conversion unconditionally, it crashes 3411-018. To be
973 -- investigated further ???
984 -- The instantiation of Unchecked_Conversion creates a wrapper package,
985 -- and the target type is declared as a subtype of the actual. Recover
986 -- the actual, which is the subtype indic. in the subtype declaration
987 -- for the target type. This is semantically correct, and avoids
988 -- anomalies with access subtypes. For entities, leave type as is.
990 -- We do the analysis here, because we do not want the compiler
991 -- to try to optimize or otherwise reorganize the unchecked
992 -- conversion node.
1003 Ttyp :=
1005 else
1018 -----------------------------
1019 -- Expand_Unc_Deallocation --
1020 -----------------------------
1033 -- This captures whether we know the argument to be non-null so that
1034 -- we can avoid the test. The reason that we need to capture this is
1035 -- that we analyze some generated statements before properly attaching
1036 -- them to the tree, and that can disturb current value settings.
1053 begin
1054 -- Nothing to do if we know the argument is null
1060 -- Processing for pointer to controlled types. Generate:
1062 -- Abrt : constant Boolean := ...;
1063 -- Ex : Exception_Occurrence;
1064 -- Raised : Boolean := False;
1066 -- begin
1067 -- Abort_Defer;
1069 -- begin
1070 -- [Deep_]Finalize (Obj_Ref);
1072 -- exception
1073 -- when others =>
1074 -- if not Raised then
1075 -- Raised := True;
1076 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
1077 -- end;
1078 -- at end
1079 -- Abort_Undefer_Direct;
1080 -- end;
1082 -- Depending on whether exception propagation is enabled and/or aborts
1083 -- are allowed, the generated code may lack block statements.
1086 Obj_Ref :=
1090 -- If the designated type is tagged, the finalization call must
1091 -- dispatch because the designated type may not be the actual type
1092 -- of the object. If the type is synchronized, the deallocation
1093 -- applies to the corresponding record type.
1097 Obj_Ref :=
1098 Unchecked_Convert_To
1100 Obj_Ref);
1103 Obj_Ref :=
1107 -- Otherwise the designated type is untagged. Set the type of the
1108 -- dereference explicitly to force a conversion when needed given
1109 -- that [Deep_]Finalize may be inherited from a parent type.
1111 else
1115 -- Generate:
1116 -- [Deep_]Finalize (Obj_Ref);
1120 -- Generate:
1121 -- Abrt : constant Boolean := ...;
1122 -- Ex : Exception_Occurrence;
1123 -- Raised : Boolean := False;
1125 -- begin
1126 -- <Fin_Call>
1128 -- exception
1129 -- when others =>
1130 -- if not Raised then
1131 -- Raised := True;
1132 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
1133 -- end;
1138 Fin_Blk :=
1140 Handled_Statement_Sequence =>
1146 -- Otherwise exception propagation is not allowed
1148 else
1152 -- The finalization action must be protected by an abort defer and
1153 -- undefer pair when aborts are allowed. Generate:
1155 -- begin
1156 -- Abort_Defer;
1157 -- <Fin_Blk>
1158 -- at end
1159 -- Abort_Undefer_Direct;
1160 -- end;
1165 Abrt_HSS :=
1169 Fin_Blk),
1172 Abrt_Blk :=
1179 -- Present the Abort_Undefer_Direct function to the backend so
1180 -- that it can inline the call to the function.
1184 -- Otherwise aborts are not allowed
1186 else
1193 -- For a task type, call Free_Task before freeing the ATCB. We used to
1194 -- detect the case of Abort followed by a Free here, because the Free
1195 -- wouldn't actually free if it happens before the aborted task actually
1196 -- terminates. The warning was removed, because Free now works properly
1197 -- (the task will be freed once it terminates).
1203 -- For composite types that contain tasks, recurse over the structure
1204 -- to build the selectors for the task subcomponents.
1215 -- Same for simple protected types. Eventually call Finalize_Protection
1216 -- before freeing the PO for each protected component.
1231 -- Normal processing for non-controlled types. The argument to free is
1232 -- a renaming rather than a constant to ensure that the original context
1233 -- is always set to null after the deallocation takes place.
1240 -- Attach to tree before analysis of generated subtypes below
1244 -- Deal with storage pool
1248 -- Freeing the secondary stack is meaningless
1253 -- If the pool object is of a simple storage pool type, then attempt
1254 -- to locate the type's Deallocate procedure, if any, and set the
1255 -- free operation's procedure to call. If the type doesn't have a
1256 -- Deallocate (which is allowed), then the actual will simply be set
1257 -- to null.
1259 elsif Present
1261 then
1262 declare
1266 begin
1272 then
1275 else
1281 -- Case of a class-wide pool type: make a dispatching call to
1282 -- Deallocate through the class-wide Deallocate_Any.
1287 -- Case of a specific pool type: make a statically bound call
1289 else
1290 Set_Procedure_To_Call
1297 -- For all cases of a Deallocate call, the back-end needs to be able
1298 -- to compute the size of the object being freed. This may require
1299 -- some adjustments for objects of dynamic size.
1300 --
1301 -- If the type is class wide, we generate an implicit type with the
1302 -- right dynamic size, so that the deallocate call gets the right
1303 -- size parameter computed by GIGI. Same for an access to
1304 -- unconstrained packed array.
1307 or else
1311 then
1312 declare
1319 begin
1320 -- Perform minor decoration as it is needed by the side effect
1321 -- removal mechanism.
1330 else
1338 -- Force freezing at the point of the dereference. For the
1339 -- class wide case, this avoids having the subtype frozen
1340 -- before the equivalent type.
1349 -- Ada 2005 (AI-251): In case of abstract interface type we must
1350 -- displace the pointer to reference the base of the object to
1351 -- deallocate its memory, unless we're targetting a VM, in which case
1352 -- no special processing is required.
1354 -- Generate:
1355 -- free (Base_Address (Obj_Ptr))
1358 and then Tagged_Type_Expansion
1359 then
1363 Name =>
1368 -- Generate:
1369 -- free (Obj_Ptr)
1371 else
1375 -- Only remaining step is to set result to null, or generate a raise of
1376 -- Constraint_Error if the target object is "not null".
1383 else
1384 declare
1386 begin
1395 -- Generate a test of whether any earlier finalization raised an
1396 -- exception, and in that case raise Program_Error with the previous
1397 -- exception occurrence.
1399 -- Generate:
1400 -- if Raised and then not Abrt then
1401 -- raise Program_Error; -- for restricted RTS
1402 -- <or>
1403 -- Raise_From_Controlled_Operation (E); -- all other cases
1404 -- end if;
1410 -- If we know the argument is non-null, then make a block statement
1411 -- that contains the required statements, no need for a test.
1414 Gen_Code :=
1416 Handled_Statement_Sequence =>
1420 -- If the argument may be null, wrap the statements inside an IF that
1421 -- does an explicit test to exclude the null case.
1423 else
1424 Gen_Code :=
1426 Condition =>
1433 -- Rewrite the call
1439 -----------------------
1440 -- Expand_To_Address --
1441 -----------------------
1448 begin
1467 -----------------------
1468 -- Expand_To_Pointer --
1469 -----------------------
1474 begin