| blob | 3d0934c8d69e5794b79923f915d4db4299d9485f |
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.
428 Condition =>
430 Left_Opnd =>
432 Right_Opnd =>
441 -- If the result type is not known to be a parent of Tag_Arg then we
442 -- need to locate the tag of the secondary dispatch table.
446 and then Tagged_Type_Expansion
447 then
448 -- Obtain the reference to the Ada.Tags service before generating
449 -- the Object_Declaration node to ensure that if this service is
450 -- not available in the runtime then we generate a clear error.
452 declare
456 begin
459 -- The tag is the first entry in the dispatch table of the
460 -- return type of the constructor.
462 Iface_Tag :=
465 Object_Definition =>
467 Expression =>
472 New_Occurrence_Of
475 Loc))));
481 -- Create the call to the actual Constructor function
483 Cnstr_Call :=
488 -- Establish its controlling tag from the tag passed to the instance
489 -- The tag may be given by a function call, in which case a temporary
490 -- should be generated now, to prevent out-of-order insertions during
491 -- the expansion of that call when stack-checking is enabled.
496 else
501 -- Rewrite and analyze the call to the instance as a class-wide
502 -- conversion of the call to the actual constructor.
506 -- Do not generate a run-time check on the built object if tag
507 -- checks are suppressed for the result type or tagged type expansion
508 -- is disabled.
511 or else not Tagged_Type_Expansion
512 then
515 -- Generate a class-wide membership test to ensure that the call's tag
516 -- argument denotes a type within the class. We must keep separate the
517 -- case in which the Result_Type of the constructor function is a tagged
518 -- type from the case in which it is an abstract interface because the
519 -- run-time subprogram required to check these cases differ (and have
520 -- one difference in their parameters profile).
522 -- Call CW_Membership if the Result_Type is a tagged type to look for
523 -- the tag in the table of ancestor tags.
526 declare
530 begin
533 Typ_Tag_Node =>
534 New_Occurrence_Of (
542 Condition =>
544 Then_Statements =>
549 -- Call IW_Membership test if the Result_Type is an abstract interface
550 -- to look for the tag in the table of interface tags.
552 else
555 Condition =>
564 New_Occurrence_Of (
567 Then_Statements =>
568 New_List (
576 ---------------------------
577 -- Expand_Exception_Call --
578 ---------------------------
580 -- If the function call is not within an exception handler, then the call
581 -- is replaced by a null string. Otherwise the appropriate routine in
582 -- Ada.Exceptions is called passing the choice parameter specification
583 -- from the enclosing handler. If the enclosing handler lacks a choice
584 -- parameter, then one is supplied.
591 begin
592 -- Climb up parents to see if we are in exception handler
595 loop
596 -- Case of not in exception handler, replace by null string
604 -- Case of in exception handler
608 -- Handler cannot be used for a local raise, and furthermore, this
609 -- is a violation of the No_Exception_Propagation restriction.
614 -- If no choice parameter present, then put one there. Note that
615 -- we do not need to put it on the entity chain, since no one will
616 -- be referencing it by normal visibility methods.
633 -- Keep climbing
635 else
643 ------------------------
644 -- Expand_Import_Call --
645 ------------------------
647 -- The function call must have a static string as its argument. We create
648 -- a dummy variable which uses this string as the external name in an
649 -- Import pragma. The result is then obtained as the address of this
650 -- dummy variable, converted to the appropriate target type.
658 begin
662 Object_Definition =>
687 ---------------------------
688 -- Expand_Intrinsic_Call --
689 ---------------------------
694 begin
695 -- If an external name is specified for the intrinsic, it is handled
696 -- by the back-end: leave the call node unchanged for now.
702 -- If the intrinsic subprogram is generic, gets its original name
706 then
708 else
731 Name_Import_Largest_Value,
732 Name_Import_Value)
733 then
767 Name_Line,
768 Name_Source_Location,
769 Name_Enclosing_Entity,
770 Name_Compilation_ISO_Date,
771 Name_Compilation_Date,
772 Name_Compilation_Time)
773 then
776 -- If we have a renaming, expand the call to the original operation,
777 -- which must itself be intrinsic, since renaming requires matching
778 -- conventions and this has already been checked.
786 -- The only other case is where an external name was specified, since
787 -- this is the only way that an otherwise unrecognized name could
788 -- escape the checking in Sem_Prag. Nothing needs to be done in such
789 -- a case, since we pass such a call to the back end unchanged.
791 else
796 ------------------------
797 -- Expand_Is_Negative --
798 ------------------------
804 begin
806 -- We replace the function call by the following expression
808 -- if Opnd < 0.0 then
809 -- True
810 -- else
811 -- if Opnd > 0.0 then
812 -- False;
813 -- else
814 -- Float_Unsigned!(Float (Opnd)) /= 0
815 -- end if;
816 -- end if;
836 Left_Opnd =>
837 Unchecked_Convert_To
839 Convert_To
842 Right_Opnd =>
848 ------------------
849 -- Expand_Shift --
850 ------------------
852 -- This procedure is used to convert a call to a shift function to the
853 -- corresponding operator node. This conversion is not done by the usual
854 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to
855 -- operator nodes, because shifts are not predefined operators.
857 -- As a result, whenever a shift is used in the source program, it will
858 -- remain as a call until converted by this routine to the operator node
859 -- form which the back end is expecting to see.
861 -- Note: it is possible for the expander to generate shift operator nodes
862 -- directly, which will be analyzed in the normal manner by calling Analyze
863 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
875 begin
884 then
890 -- Note that we don't call Analyze and Resolve on this node, because
891 -- it already got analyzed and resolved when it was a function call.
897 -- However, we do call the expander, so that the expansion for
898 -- rotates and shift_right_arithmetic happens if Modify_Tree_For_C
899 -- is set.
905 else
906 -- If the context type is not the type of the operator, it is an
907 -- inherited operator for a derived type. Wrap the node in a
908 -- conversion so that it is type-consistent for possible further
909 -- expansion (e.g. within a lock-free protected type).
915 -- Analyze and resolve result formed by conversion to target type
921 ------------------------
922 -- Expand_Source_Info --
923 ------------------------
927 begin
928 -- Integer cases
936 -- String cases
938 else
939 declare
941 begin
951 ---------------------------
952 -- Expand_Unc_Conversion --
953 ---------------------------
961 begin
962 -- Rewrite as unchecked conversion node. Note that we must convert
963 -- the operand to the formal type of the input parameter of the
964 -- function, so that the resulting N_Unchecked_Type_Conversion
965 -- call indicates the correct types for Gigi.
967 -- Right now, we only do this if a scalar type is involved. It is
968 -- not clear if it is needed in other cases. If we do attempt to
969 -- do the conversion unconditionally, it crashes 3411-018. To be
970 -- investigated further ???
981 -- The instantiation of Unchecked_Conversion creates a wrapper package,
982 -- and the target type is declared as a subtype of the actual. Recover
983 -- the actual, which is the subtype indic. in the subtype declaration
984 -- for the target type. This is semantically correct, and avoids
985 -- anomalies with access subtypes. For entities, leave type as is.
987 -- We do the analysis here, because we do not want the compiler
988 -- to try to optimize or otherwise reorganize the unchecked
989 -- conversion node.
1000 Ttyp :=
1002 else
1015 -----------------------------
1016 -- Expand_Unc_Deallocation --
1017 -----------------------------
1030 -- This captures whether we know the argument to be non-null so that
1031 -- we can avoid the test. The reason that we need to capture this is
1032 -- that we analyze some generated statements before properly attaching
1033 -- them to the tree, and that can disturb current value settings.
1050 begin
1051 -- Nothing to do if we know the argument is null
1057 -- Processing for pointer to controlled types. Generate:
1059 -- Abrt : constant Boolean := ...;
1060 -- Ex : Exception_Occurrence;
1061 -- Raised : Boolean := False;
1063 -- begin
1064 -- Abort_Defer;
1066 -- begin
1067 -- [Deep_]Finalize (Obj_Ref);
1069 -- exception
1070 -- when others =>
1071 -- if not Raised then
1072 -- Raised := True;
1073 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
1074 -- end;
1075 -- at end
1076 -- Abort_Undefer_Direct;
1077 -- end;
1079 -- Depending on whether exception propagation is enabled and/or aborts
1080 -- are allowed, the generated code may lack block statements.
1083 Obj_Ref :=
1087 -- If the designated type is tagged, the finalization call must
1088 -- dispatch because the designated type may not be the actual type
1089 -- of the object. If the type is synchronized, the deallocation
1090 -- applies to the corresponding record type.
1094 Obj_Ref :=
1095 Unchecked_Convert_To
1097 Obj_Ref);
1100 Obj_Ref :=
1104 -- Otherwise the designated type is untagged. Set the type of the
1105 -- dereference explicitly to force a conversion when needed given
1106 -- that [Deep_]Finalize may be inherited from a parent type.
1108 else
1112 -- Generate:
1113 -- [Deep_]Finalize (Obj_Ref);
1117 -- Generate:
1118 -- Abrt : constant Boolean := ...;
1119 -- Ex : Exception_Occurrence;
1120 -- Raised : Boolean := False;
1122 -- begin
1123 -- <Fin_Call>
1125 -- exception
1126 -- when others =>
1127 -- if not Raised then
1128 -- Raised := True;
1129 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
1130 -- end;
1135 Fin_Blk :=
1137 Handled_Statement_Sequence =>
1143 -- Otherwise exception propagation is not allowed
1145 else
1149 -- The finalization action must be protected by an abort defer and
1150 -- undefer pair when aborts are allowed. Generate:
1152 -- begin
1153 -- Abort_Defer;
1154 -- <Fin_Blk>
1155 -- at end
1156 -- Abort_Undefer_Direct;
1157 -- end;
1162 Abrt_HSS :=
1166 Fin_Blk),
1169 Abrt_Blk :=
1176 -- Present the Abort_Undefer_Direct function to the backend so
1177 -- that it can inline the call to the function.
1181 -- Otherwise aborts are not allowed
1183 else
1190 -- For a task type, call Free_Task before freeing the ATCB. We used to
1191 -- detect the case of Abort followed by a Free here, because the Free
1192 -- wouldn't actually free if it happens before the aborted task actually
1193 -- terminates. The warning was removed, because Free now works properly
1194 -- (the task will be freed once it terminates).
1200 -- For composite types that contain tasks, recurse over the structure
1201 -- to build the selectors for the task subcomponents.
1212 -- Same for simple protected types. Eventually call Finalize_Protection
1213 -- before freeing the PO for each protected component.
1228 -- Normal processing for non-controlled types. The argument to free is
1229 -- a renaming rather than a constant to ensure that the original context
1230 -- is always set to null after the deallocation takes place.
1237 -- Attach to tree before analysis of generated subtypes below
1241 -- Deal with storage pool
1245 -- Freeing the secondary stack is meaningless
1250 -- If the pool object is of a simple storage pool type, then attempt
1251 -- to locate the type's Deallocate procedure, if any, and set the
1252 -- free operation's procedure to call. If the type doesn't have a
1253 -- Deallocate (which is allowed), then the actual will simply be set
1254 -- to null.
1256 elsif Present
1258 then
1259 declare
1263 begin
1269 then
1272 else
1278 -- Case of a class-wide pool type: make a dispatching call to
1279 -- Deallocate through the class-wide Deallocate_Any.
1284 -- Case of a specific pool type: make a statically bound call
1286 else
1287 Set_Procedure_To_Call
1294 -- For all cases of a Deallocate call, the back-end needs to be able
1295 -- to compute the size of the object being freed. This may require
1296 -- some adjustments for objects of dynamic size.
1297 --
1298 -- If the type is class wide, we generate an implicit type with the
1299 -- right dynamic size, so that the deallocate call gets the right
1300 -- size parameter computed by GIGI. Same for an access to
1301 -- unconstrained packed array.
1304 or else
1308 then
1309 declare
1316 begin
1317 -- Perform minor decoration as it is needed by the side effect
1318 -- removal mechanism.
1327 else
1335 -- Force freezing at the point of the dereference. For the
1336 -- class wide case, this avoids having the subtype frozen
1337 -- before the equivalent type.
1346 -- Ada 2005 (AI-251): In case of abstract interface type we must
1347 -- displace the pointer to reference the base of the object to
1348 -- deallocate its memory, unless we're targetting a VM, in which case
1349 -- no special processing is required.
1351 -- Generate:
1352 -- free (Base_Address (Obj_Ptr))
1355 and then Tagged_Type_Expansion
1356 then
1360 Name =>
1365 -- Generate:
1366 -- free (Obj_Ptr)
1368 else
1372 -- Only remaining step is to set result to null, or generate a raise of
1373 -- Constraint_Error if the target object is "not null".
1380 else
1381 declare
1383 begin
1392 -- Generate a test of whether any earlier finalization raised an
1393 -- exception, and in that case raise Program_Error with the previous
1394 -- exception occurrence.
1396 -- Generate:
1397 -- if Raised and then not Abrt then
1398 -- raise Program_Error; -- for restricted RTS
1399 -- <or>
1400 -- Raise_From_Controlled_Operation (E); -- all other cases
1401 -- end if;
1407 -- If we know the argument is non-null, then make a block statement
1408 -- that contains the required statements, no need for a test.
1411 Gen_Code :=
1413 Handled_Statement_Sequence =>
1417 -- If the argument may be null, wrap the statements inside an IF that
1418 -- does an explicit test to exclude the null case.
1420 else
1421 Gen_Code :=
1423 Condition =>
1430 -- Rewrite the call
1436 -----------------------
1437 -- Expand_To_Address --
1438 -----------------------
1445 begin
1464 -----------------------
1465 -- Expand_To_Pointer --
1466 -----------------------
1471 begin