| blob | 7bfe72455b9046c9742a55348a9261c027f0e194 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ U T I L --
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 ------------------------------------------------------------------------------
76 ----------------------------------------
77 -- Global Variables for New_Copy_Tree --
78 ----------------------------------------
80 -- These global variables are used by New_Copy_Tree. See description of the
81 -- body of this subprogram for details. Global variables can be safely used
82 -- by New_Copy_Tree, since there is no case of a recursive call from the
83 -- processing inside New_Copy_Tree.
86 -- If there are more than this number of pairs of entries in the map, then
87 -- Hash_Tables_Used will be set, and the hash tables will be initialized
88 -- and used for the searches.
91 -- Set to True if hash tables are in use
94 -- Count entries in table to see if threshold is reached
97 -- Set to True if hash table contains data. We set this True if we setup
98 -- the hash table with data, and leave it set permanently from then on,
99 -- this is a signal that second and subsequent users of the hash table
100 -- must clear the old entries before reuse.
103 -- Defines range of headers in hash tables (512 headers)
105 -----------------------
106 -- Local Subprograms --
107 -----------------------
109 function Build_Component_Subtype
113 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
114 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
115 -- Loc is the source location, T is the original subtype.
117 function Has_Enabled_Property
120 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
121 -- Determine whether an abstract state or a variable denoted by entity
122 -- Item_Id has enabled property Property.
125 -- T is a derived tagged type. Check whether the type extension is null.
126 -- If the parent type is fully initialized, T can be treated as such.
129 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
130 -- with discriminants whose default values are static, examine only the
131 -- components in the selected variant to determine whether all of them
132 -- have a default.
134 ------------------------------
135 -- Abstract_Interface_List --
136 ------------------------------
141 begin
144 -- If we are dealing with a synchronized subtype, go to the base
145 -- type, whose declaration has the interface list.
147 -- Shouldn't this be Declaration_Node???
161 and then
163 then
166 -- If the full-view is not available we cannot do anything else
167 -- here (the source has errors).
169 else
173 -- Support for generic formals with interfaces is still missing ???
178 else
179 pragma Assert
189 -- Recurse, because parent may still be a private extension. Also
190 -- note that the full view of the subtype or the full view of its
191 -- base type may (both) be unavailable.
198 else
206 --------------------------------
207 -- Add_Access_Type_To_Process --
208 --------------------------------
213 begin
225 --------------------------
226 -- Add_Block_Identifier --
227 --------------------------
232 begin
235 -- The block already has a label, return its entity
240 -- Create a new block label and set its attributes
242 else
252 ----------------------------
253 -- Add_Global_Declaration --
254 ----------------------------
259 begin
268 --------------------------------
269 -- Address_Integer_Convert_OK --
270 --------------------------------
273 begin
274 if Allow_Integer_Address
278 or else
282 then
284 else
289 -----------------
290 -- Addressable --
291 -----------------
293 -- For now, just 8/16/32/64. but analyze later if AAMP is special???
296 begin
304 begin
311 ---------------------------------
312 -- Aggregate_Constraint_Checks --
313 ---------------------------------
315 procedure Aggregate_Constraint_Checks
318 is
321 begin
326 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
327 -- component's type to force the appropriate accessibility checks.
329 -- Ada 2005 (AI-231): Generate conversion to the null-excluding
330 -- type to force the corresponding run-time check
336 then
342 -- This is really expansion activity, so make sure that expansion is
343 -- on and is allowed. In GNATprove mode, we also want check flags to
344 -- be added in the tree, so that the formal verification can rely on
345 -- those to be present. In GNATprove mode for formal verification, some
346 -- treatment typically only done during expansion needs to be performed
347 -- on the tree, but it should not be applied inside generics. Otherwise,
348 -- this breaks the name resolution mechanism for generic instances.
350 if not Expander_Active
352 then
356 -- First check if we have to insert discriminant checks
361 -- Next emit length checks for array aggregates
366 -- Finally emit scalar and string checks. If we are dealing with a
367 -- scalar literal we need to check by hand because the Etype of
368 -- literals is not necessarily correct.
372 then
374 Apply_Compile_Time_Constraint_Error
380 Apply_Compile_Time_Constraint_Error
389 -- Verify that target type is also scalar, to prevent view anomalies
390 -- in instantiations.
396 then
399 then
400 -- If expression is a constant, it is worthwhile checking whether
401 -- it is a bound of the type.
405 or else
408 then
411 else
417 -- Could use a comment on this case ???
419 else
428 -----------------------
429 -- Alignment_In_Bits --
430 -----------------------
433 begin
437 --------------------------------------
438 -- All_Composite_Constraints_Static --
439 --------------------------------------
441 function All_Composite_Constraints_Static
443 is
444 begin
453 then
455 return
461 return
463 and then
468 then
469 return
470 Is_OK_Static_Expression
472 and then
473 Is_OK_Static_Expression
477 return
486 return
490 declare
492 begin
506 return
508 and then
516 ---------------------------------
517 -- Append_Inherited_Subprogram --
518 ---------------------------------
522 -- The parent subprogram
525 -- The scope of definition of the parent subprogram
528 -- The derived type of which S is a primitive operation
533 begin
539 then
540 -- The inherited operation is available at the earliest place after
541 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
542 -- relevant for type extensions. If the parent operation appears
543 -- after the type extension, the operation is not visible.
545 Decl := First
546 (Visible_Declarations
551 then
558 else
567 -- If partial view is not a type extension, or it appears before the
568 -- subprogram declaration, insert normally at end of entity list.
573 -----------------------------------------
574 -- Apply_Compile_Time_Constraint_Error --
575 -----------------------------------------
577 procedure Apply_Compile_Time_Constraint_Error
586 is
592 begin
595 else
599 Discard_Node
606 -- Now we replace the node by an N_Raise_Constraint_Error node
607 -- This does not need reanalyzing, so set it as analyzed now.
615 -- Now deal with possible local raise handling
619 -- If the original expression was marked as static, the result is
620 -- still marked as static, but the Raises_Constraint_Error flag is
621 -- always set so that further static evaluation is not attempted.
628 ---------------------------
629 -- Async_Readers_Enabled --
630 ---------------------------
633 begin
637 ---------------------------
638 -- Async_Writers_Enabled --
639 ---------------------------
642 begin
646 --------------------------------------
647 -- Available_Full_View_Of_Component --
648 --------------------------------------
653 begin
659 -------------------
660 -- Bad_Attribute --
661 -------------------
663 procedure Bad_Attribute
667 is
668 begin
672 -- Check for possible misspelling
677 Error_Msg_N -- CODEFIX
686 --------------------------------
687 -- Bad_Predicated_Subtype_Use --
688 --------------------------------
690 procedure Bad_Predicated_Subtype_Use
695 is
698 begin
699 -- Avoid cascaded errors
722 -- The restriction on loop parameters is only that the type
723 -- should have no dynamic predicates.
728 then
748 else
752 else
756 -- Emit an optional suggestion on how to remedy the error if the
757 -- context warrants it.
765 -----------------------------------------
766 -- Bad_Unordered_Enumeration_Reference --
767 -----------------------------------------
769 function Bad_Unordered_Enumeration_Reference
772 is
773 begin
775 and then Warn_On_Unordered_Enumeration_Type
782 --------------------------
783 -- Build_Actual_Subtype --
784 --------------------------
786 function Build_Actual_Subtype
789 is
791 -- Normally Sloc (N), but may point to corresponding body in some cases
802 begin
808 -- If this is a formal parameter of a subprogram declaration, and
809 -- we are compiling the body, we want the declaration for the
810 -- actual subtype to carry the source position of the body, to
811 -- prevent anomalies in gdb when stepping through the code.
814 declare
816 begin
819 then
825 else
833 -- Build an array subtype declaration with the nominal subtype and
834 -- the bounds of the actual. Add the declaration in front of the
835 -- local declarations for the subprogram, for analysis before any
836 -- reference to the formal in the body.
838 Lo :=
840 Prefix =>
846 Hi :=
848 Prefix =>
857 -- If the type has unknown discriminants there is no constrained
858 -- subtype to build. This is never called for a formal or for a
859 -- lhs, so returning the type is ok ???
864 else
867 -- Type T is a generic derived type, inherit the discriminants from
868 -- the parent type.
873 -- T was flagged as an error if it was declared as a formal
874 -- derived type with known discriminants. In this case there
875 -- is no need to look at the parent type since T already carries
876 -- its own discriminants.
879 then
881 else
889 Prefix =>
899 Decl :=
902 Subtype_Indication =>
905 Constraint =>
913 ---------------------------------------
914 -- Build_Actual_Subtype_Of_Component --
915 ---------------------------------------
917 function Build_Actual_Subtype_Of_Component
920 is
928 -- This is either a copy of T, or if T is an access type, then it is
929 -- the directly designated type of this access type.
932 -- If one or more of the bounds of the component depends on
933 -- discriminants, build actual constraint using the discriminants
934 -- of the prefix.
937 -- Similar to previous one, for discriminated components constrained
938 -- by the discriminant of the enclosing object.
940 -----------------------------------
941 -- Build_Actual_Array_Constraint --
942 -----------------------------------
952 begin
959 Lo :=
964 else
967 -- The new bound will be reanalyzed in the enclosing
968 -- declaration. For literal bounds that come from a type
969 -- declaration, the type of the context must be imposed, so
970 -- insure that analysis will take place. For non-universal
971 -- types this is not strictly necessary.
977 Hi :=
982 else
994 ------------------------------------
995 -- Build_Actual_Record_Constraint --
996 ------------------------------------
1003 begin
1011 else
1022 -- Start of processing for Build_Actual_Subtype_Of_Component
1024 begin
1025 -- Why the test for Spec_Expression mode here???
1030 -- More comments for the rest of this body would be good ???
1038 then
1039 -- If the type of the dereference is already constrained, it is an
1040 -- actual subtype.
1044 then
1046 else
1050 else
1057 else
1067 or else
1069 then
1071 return
1072 Build_Component_Subtype
1082 then
1085 then
1093 return
1094 Build_Component_Subtype (
1102 -- If none of the above, the actual and nominal subtypes are the same
1107 -----------------------------
1108 -- Build_Component_Subtype --
1109 -----------------------------
1111 function Build_Component_Subtype
1115 is
1119 begin
1120 -- Unchecked_Union components do not require component subtypes
1129 Decl :=
1132 Subtype_Indication =>
1135 Constraint =>
1143 ----------------------------------
1144 -- Build_Default_Init_Cond_Call --
1145 ----------------------------------
1147 function Build_Default_Init_Cond_Call
1151 is
1155 begin
1156 return
1165 ----------------------------------------------
1166 -- Build_Default_Init_Cond_Procedure_Bodies --
1167 ----------------------------------------------
1171 -- If type Typ is subject to pragma Default_Initial_Condition, build the
1172 -- body of the procedure which verifies the assumption of the pragma at
1173 -- run time. The generated body is added after the type declaration.
1175 --------------------------------------------
1176 -- Build_Default_Init_Cond_Procedure_Body --
1177 --------------------------------------------
1181 -- The entity of the sole formal parameter of the default initial
1182 -- condition procedure.
1185 -- Replace a single reference to type Typ with a reference to formal
1186 -- parameter Param_Id.
1188 ----------------------------
1189 -- Replace_Type_Reference --
1190 ----------------------------
1193 begin
1200 -- Local variables
1213 -- Start of processing for Build_Default_Init_Cond_Procedure_Body
1215 begin
1216 -- The procedure should be generated only for [sub]types subject to
1217 -- pragma Default_Initial_Condition. Types that inherit the pragma do
1218 -- not get this specialized procedure.
1224 -- Nothing to do if the body was already built
1230 -- The related type may be subject to pragma Ghost. Set the mode now
1231 -- to ensure that the analysis and expansion produce Ghost nodes.
1237 -- The pragma has an argument. Note that the argument is analyzed
1238 -- after all references to the current instance of the type are
1239 -- replaced.
1242 Expr :=
1248 -- Preserve the original argument of the pragma by replicating it.
1249 -- Replace all references to the current instance of the type with
1250 -- references to the formal parameter.
1252 else
1256 -- Generate:
1257 -- pragma Check (Default_Initial_Condition, <Expr>);
1259 Stmt :=
1261 Pragma_Identifier =>
1266 Expression =>
1273 -- Otherwise the pragma appears without an argument
1275 else
1279 -- Generate:
1280 -- procedure <Typ>Default_Init_Cond (I : <Typ>) is
1281 -- begin
1282 -- <Stmt>;
1283 -- end <Typ>Default_Init_Cond;
1285 Body_Decl :=
1287 Specification =>
1290 Handled_Statement_Sequence =>
1294 -- Link the spec and body of the default initial condition procedure
1295 -- to prevent the generation of a duplicate body.
1304 -- Local variables
1309 -- Start of processing for Build_Default_Init_Cond_Procedure_Bodies
1311 begin
1312 -- Inspect the private declarations looking for [sub]type declarations
1317 N_Subtype_Declaration)
1318 then
1321 -- Guard against partially decorate types due to previous errors
1325 -- If the type is subject to pragma Default_Initial_Condition,
1326 -- generate the body of the internal procedure which verifies
1327 -- the assertion of the pragma at run time.
1332 -- A derived type inherits the default initial condition
1333 -- procedure from its parent type.
1345 ---------------------------------------------------
1346 -- Build_Default_Init_Cond_Procedure_Declaration --
1347 ---------------------------------------------------
1358 begin
1359 -- The procedure should be generated only for types subject to pragma
1360 -- Default_Initial_Condition. Types that inherit the pragma do not get
1361 -- this specialized procedure.
1366 -- Nothing to do if default initial condition procedure already built
1372 -- The related type may be subject to pragma Ghost. Set the mode now to
1373 -- ensure that the analysis and expansion produce Ghost nodes.
1377 Proc_Id :=
1381 -- Associate default initial condition procedure with the private type
1387 -- Mark the default initial condition procedure explicitly as Ghost
1388 -- because it does not come from source.
1394 -- Generate:
1395 -- procedure <Typ>Default_Init_Cond (Inn : <Typ>);
1399 Specification =>
1410 ---------------------------
1411 -- Build_Default_Subtype --
1412 ---------------------------
1414 function Build_Default_Subtype
1417 is
1422 -- The base type that is to be constrained by the defaults
1424 begin
1431 -- If T is non-private but its base type is private, this is the
1432 -- completion of a subtype declaration whose parent type is private
1433 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1434 -- are to be found in the full view of the base. Check that the private
1435 -- status of T and its base differ.
1440 then
1450 declare
1455 begin
1462 Decl :=
1465 Subtype_Indication =>
1468 Constraint =>
1474 -- If the context is a component declaration the subtype declaration
1475 -- will be analyzed when the enclosing type is frozen, otherwise do
1476 -- it now.
1486 --------------------------------------------
1487 -- Build_Discriminal_Subtype_Of_Component --
1488 --------------------------------------------
1490 function Build_Discriminal_Subtype_Of_Component
1492 is
1498 -- If one or more of the bounds of the component depends on
1499 -- discriminants, build actual constraint using the discriminants
1500 -- of the prefix.
1503 -- Similar to previous one, for discriminated components constrained by
1504 -- the discriminant of the enclosing object.
1506 ----------------------------------------
1507 -- Build_Discriminal_Array_Constraint --
1508 ----------------------------------------
1518 begin
1527 else
1534 else
1545 -----------------------------------------
1546 -- Build_Discriminal_Record_Constraint --
1547 -----------------------------------------
1554 begin
1558 D_Val :=
1560 else
1571 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1573 begin
1578 or else
1580 then
1581 return Build_Component_Subtype
1591 then
1595 return Build_Component_Subtype
1603 -- If none of the above, the actual and nominal subtypes are the same
1608 ------------------------------
1609 -- Build_Elaboration_Entity --
1610 ------------------------------
1618 -- Given an entity, sets the fully qualified name of the entity in
1619 -- Name_Buffer, with components separated by double underscores. This
1620 -- is a recursive routine that climbs the scope chain to Standard.
1622 ----------------------
1623 -- Set_Package_Name --
1624 ----------------------
1627 begin
1631 declare
1633 begin
1640 else
1645 -- Start of processing for Build_Elaboration_Entity
1647 begin
1648 -- Ignore call if already constructed
1653 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1654 -- no role in analysis.
1659 -- See if we need elaboration entity. We always need it for the dynamic
1660 -- elaboration model, since it is needed to properly generate the PE
1661 -- exception for access before elaboration.
1666 -- For the static model, we don't need the elaboration counter if this
1667 -- unit is sure to have no elaboration code, since that means there
1668 -- is no elaboration unit to be called. Note that we can't just decide
1669 -- after the fact by looking to see whether there was elaboration code,
1670 -- because that's too late to make this decision.
1675 -- Similarly, for the static model, we can skip the elaboration counter
1676 -- if we have the No_Multiple_Elaboration restriction, since for the
1677 -- static model, that's the only purpose of the counter (to avoid
1678 -- multiple elaboration).
1684 -- Here we need the elaboration entity
1686 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1687 -- name with dots replaced by double underscore. We have to manually
1688 -- construct this name, since it will be elaborated in the outer scope,
1689 -- and thus will not have the unit name automatically prepended.
1694 -- Create elaboration counter
1699 Decl :=
1702 Object_Definition =>
1708 Pop_Scope;
1710 -- Reset True_Constant indication, since we will indeed assign a value
1711 -- to the variable in the binder main. We also kill the Current_Value
1712 -- and Last_Assignment fields for the same reason.
1718 -- We do not want any further qualification of the name (if we did not
1719 -- do this, we would pick up the name of the generic package in the case
1720 -- of a library level generic instantiation).
1726 --------------------------------
1727 -- Build_Explicit_Dereference --
1728 --------------------------------
1730 procedure Build_Explicit_Dereference
1733 is
1738 begin
1739 -- An entity of a type with a reference aspect is overloaded with
1740 -- both interpretations: with and without the dereference. Now that
1741 -- the dereference is made explicit, set the type of the node properly,
1742 -- to prevent anomalies in the backend. Same if the expression is an
1743 -- overloaded function call whose return type has a reference aspect.
1750 -- If the name of the indexing function is overloaded, locate the one
1751 -- whose return type has an implicit dereference on the desired
1752 -- discriminant, and set entity and type of function call.
1760 then
1770 -- Set type of call from resolved function name.
1777 -- The expression will often be a generalized indexing that yields a
1778 -- container element that is then dereferenced, in which case the
1779 -- generalized indexing call is also non-overloaded.
1783 then
1789 Prefix =>
1797 -----------------------------------
1798 -- Cannot_Raise_Constraint_Error --
1799 -----------------------------------
1802 begin
1812 else
1830 else
1831 declare
1834 begin
1839 else
1852 then
1854 else
1864 else
1868 when N_Op_Divide |
1869 N_Op_Mod |
1870 N_Op_Rem
1871 =>
1873 or else
1875 then
1877 else
1878 return
1880 and then
1884 when N_Op_Add |
1885 N_Op_And |
1886 N_Op_Concat |
1887 N_Op_Eq |
1888 N_Op_Expon |
1889 N_Op_Ge |
1890 N_Op_Gt |
1891 N_Op_Le |
1892 N_Op_Lt |
1893 N_Op_Multiply |
1894 N_Op_Ne |
1895 N_Op_Or |
1896 N_Op_Rotate_Left |
1897 N_Op_Rotate_Right |
1898 N_Op_Shift_Left |
1899 N_Op_Shift_Right |
1900 N_Op_Shift_Right_Arithmetic |
1901 N_Op_Subtract |
1902 N_Op_Xor
1903 =>
1906 else
1907 return
1909 and then
1919 -----------------------------
1920 -- Check_Part_Of_Reference --
1921 -----------------------------
1931 begin
1932 -- Traverse the parent chain looking for a suitable context for the
1933 -- reference to the concurrent constituent.
1940 -- A concurrent constituent is allowed to appear in pragmas
1941 -- Initial_Condition and Initializes as this is part of the
1942 -- elaboration checks for the constituent (SPARK RM 9.3).
1948 -- When the reference appears within pragma Depends or Global,
1949 -- check whether the pragma applies to a single task type. Note
1950 -- that the pragma is not encapsulated by the type definition,
1951 -- but this is still a valid context.
1958 then
1964 -- The reference appears somewhere in the definition of the single
1965 -- protected/task type (SPARK RM 9.3).
1968 N_Single_Task_Declaration)
1970 then
1974 -- The reference appears within the expanded declaration or the body
1975 -- of the single protected/task type (SPARK RM 9.3).
1978 N_Protected_Type_Declaration,
1979 N_Task_Body,
1980 N_Task_Type_Declaration)
1981 then
1986 then
1991 -- The reference has been relocated within an internally generated
1992 -- package or subprogram. Assume that the reference is legal as the
1993 -- real check was already performed in the original context of the
1994 -- reference.
1997 N_Package_Declaration,
1998 N_Subprogram_Body,
1999 N_Subprogram_Declaration)
2001 then
2005 -- The reference has been relocated to an inlined body for GNATprove.
2006 -- Assume that the reference is legal as the real check was already
2007 -- performed in the original context of the reference.
2009 elsif GNATprove_Mode
2012 then
2020 -- The reference is illegal as it appears outside the definition or
2021 -- body of the single protected/task type.
2024 Error_Msg_NE
2030 Error_Msg_NE
2032 else
2033 Error_Msg_NE
2039 -----------------------------------------
2040 -- Check_Dynamically_Tagged_Expression --
2041 -----------------------------------------
2043 procedure Check_Dynamically_Tagged_Expression
2047 is
2048 begin
2051 -- In order to avoid spurious errors when analyzing the expanded code,
2052 -- this check is done only for nodes that come from source and for
2053 -- actuals of generic instantiations.
2061 then
2066 --------------------------
2067 -- Check_Fully_Declared --
2068 --------------------------
2071 begin
2074 -- Ada 2005 (AI-50217): If the type is available through a limited
2075 -- with_clause, verify that its full view has been analyzed.
2080 then
2081 -- The non-limited view is fully declared
2085 else
2086 Error_Msg_NE
2090 -- Need comments for these tests ???
2094 and then not In_Spec_Expression
2095 then
2096 -- Special case: if T is the anonymous type created for a single
2097 -- task or protected object, use the name of the source object.
2102 then
2103 Error_Msg_NE
2106 else
2107 Error_Msg_NE
2114 -------------------------------------------
2115 -- Check_Function_With_Address_Parameter --
2116 -------------------------------------------
2122 begin
2140 -------------------------------------
2141 -- Check_Function_Writable_Actuals --
2142 -------------------------------------
2151 -- In a single traversal of subtree N collect in Writable_Actuals_List
2152 -- all the actuals of functions with writable actuals, and in the list
2153 -- Identifiers_List collect all the identifiers that are not actuals of
2154 -- functions with writable actuals. If a writable actual is referenced
2155 -- twice as writable actual then Error_Node is set to reference its
2156 -- second occurrence, the error is reported, and the tree traversal
2157 -- is abandoned.
2160 -- Return the entity associated with the function call
2163 -- Preanalyze N without reporting errors. Very dubious, you can't just
2164 -- go analyzing things more than once???
2166 -------------------------
2167 -- Collect_Identifiers --
2168 -------------------------
2173 -- Process a single node during the tree traversal to collect the
2174 -- writable actuals of functions and all the identifiers which are
2175 -- not writable actuals of functions.
2178 -- Returns True if List has a node whose Entity is Entity (N)
2180 -------------------------
2181 -- Check_Function_Call --
2182 -------------------------
2188 begin
2191 -- No analysis possible if the entity is not decorated
2196 -- Don't collect identifiers of packages, called functions, etc
2199 E_Function,
2200 E_Procedure,
2201 E_Entry)
2202 then
2205 -- For rewritten nodes, continue the traversal in the original
2206 -- subtree. Needed to handle aggregates in original expressions
2207 -- extracted from the tree by Remove_Side_Effects.
2213 -- For now we skip aggregate discriminants, since they require
2214 -- performing the analysis in two phases to identify conflicts:
2215 -- first one analyzing discriminants and second one analyzing
2216 -- the rest of components (since at run time, discriminants are
2217 -- evaluated prior to components): too much computation cost
2218 -- to identify a corner case???
2222 N_Aggregate,
2223 N_Extension_Aggregate)
2224 then
2225 declare
2228 begin
2235 then
2240 -- Analyze if N is a writable actual of a function
2243 declare
2248 begin
2251 -- In case of previous error, no check is possible
2259 then
2265 E_In_Out_Parameter)
2266 then
2282 -- Skip checking the error in non-elementary types since
2283 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
2284 -- store this actual in Writable_Actuals_List since it is
2285 -- needed to perform checks on other constructs that have
2286 -- arbitrary order of evaluation (for example, aggregates).
2293 -- Second occurrence of an elementary type writable actual
2297 -- Report the error on the second occurrence of the
2298 -- identifier. We cannot assume that N is the second
2299 -- occurrence (according to their location in the
2300 -- sources), since Traverse_Func walks through Field2
2301 -- last (see comment in the body of Traverse_Func).
2303 declare
2306 begin
2310 loop
2316 else
2320 Error_Msg_NE
2327 -- First occurrence of a elementary type writable actual
2329 else
2333 else
2345 --------------
2346 -- Contains --
2347 --------------
2349 function Contains
2352 is
2357 begin
2366 else
2374 ------------------
2375 -- Do_Traversal --
2376 ------------------
2379 -- The traversal procedure
2381 -- Start of processing for Collect_Identifiers
2383 begin
2395 ---------------------
2396 -- Get_Function_Id --
2397 ---------------------
2403 begin
2414 else
2421 -------------------------------
2422 -- Preanalyze_Without_Errors --
2423 -------------------------------
2427 begin
2433 -- Start of processing for Check_Function_Writable_Actuals
2435 begin
2436 -- The check only applies to Ada 2012 code on which Check_Actuals has
2437 -- been set, and only to constructs that have multiple constituents
2438 -- whose order of evaluation is not specified by the language.
2445 N_Aggregate,
2446 N_Extension_Aggregate,
2447 N_Full_Type_Declaration,
2448 N_Function_Call,
2449 N_Procedure_Call_Statement,
2450 N_Entry_Call_Statement))
2454 -- In addition, this check only applies to source code, not to code
2455 -- generated by constraint checks.
2458 then
2462 -- If a construct C has two or more direct constituents that are names
2463 -- or expressions whose evaluation may occur in an arbitrary order, at
2464 -- least one of which contains a function call with an in out or out
2465 -- parameter, then the construct is legal only if: for each name N that
2466 -- is passed as a parameter of mode in out or out to some inner function
2467 -- call C2 (not including the construct C itself), there is no other
2468 -- name anywhere within a direct constituent of the construct C other
2469 -- than the one containing C2, that is known to refer to the same
2470 -- object (RM 6.4.1(6.17/3)).
2478 declare
2481 begin
2490 then
2501 declare
2503 -- Return the record part of this record type definition
2507 begin
2510 else
2519 begin
2520 -- No need to perform any analysis if the record has no
2521 -- components
2527 -- Collect the identifiers starting from the deepest
2528 -- derivation. Done to report the error in the deepest
2529 -- derivation.
2531 loop
2537 then
2554 when N_Subprogram_Call |
2555 N_Entry_Call_Statement =>
2556 declare
2561 begin
2566 E_In_Out_Parameter)
2567 then
2576 when N_Aggregate |
2577 N_Extension_Aggregate =>
2578 declare
2583 begin
2584 -- Handle the N_Others_Choice of array aggregates with static
2585 -- bounds. There is no need to perform this analysis in
2586 -- aggregates without static bounds since we cannot evaluate
2587 -- if the N_Others_Choice covers several elements. There is
2588 -- no need to handle the N_Others choice of record aggregates
2589 -- since at this stage it has been already expanded by
2590 -- Resolve_Record_Aggregate.
2597 >
2599 then
2600 declare
2607 begin
2608 -- Count positional associations
2618 -- Count the rest of elements and locate the N_Others
2619 -- choice (if any)
2630 -- Count several components
2633 N_Subtype_Indication)
2636 then
2637 declare
2639 begin
2641 pragma Assert
2644 Count_Components :=
2645 Count_Components
2649 -- Count single component. No other case available
2650 -- since we are handling an aggregate with static
2651 -- bounds.
2653 else
2667 Num_Components :=
2673 -- Handle the N_Others choice if it covers several
2674 -- components
2678 then
2681 -- At this stage, if expansion is active, the
2682 -- expression of the others choice has not been
2683 -- analyzed. Hence we generate a duplicate and
2684 -- we analyze it silently to have available the
2685 -- minimum decoration required to collect the
2686 -- identifiers.
2690 else
2691 Comp_Expr :=
2700 -- As suggested by Robert, at current stage we
2701 -- report occurrences of this case as warnings.
2703 Error_Msg_N
2713 -- For an array aggregate, a discrete_choice_list that has
2714 -- a nonstatic range is considered as two or more separate
2715 -- occurrences of the expression (RM 6.4.1(20/3)).
2721 then
2722 -- Collect identifiers found in the dynamic bounds
2724 declare
2728 begin
2734 N_Subtype_Indication)
2737 then
2756 -- The RM rule is violated if there is more than
2757 -- a single choice in a component association.
2759 else
2764 then
2781 -- Handle ancestor part of extension aggregates
2787 -- Handle positional associations
2800 -- Handle discrete associations
2810 -- For now we skip discriminants since it requires
2811 -- performing the analysis in two phases: first one
2812 -- analyzing discriminants and second one analyzing
2813 -- the rest of components since discriminants are
2814 -- evaluated prior to components: too much extra
2815 -- work to detect a corner case???
2820 then
2826 else
2828 Comp_Expr :=
2832 else
2852 -- No further action needed if we already reported an error
2858 -- Check violation of RM 6.20/3 in aggregates
2862 then
2863 Error_Msg_N
2870 -- Check if some writable argument of a function is referenced
2874 then
2875 declare
2879 begin
2886 when N_Aggregate |
2887 N_Component_Association |
2888 N_Component_Declaration =>
2889 Error_Msg_N
2896 Error_Msg_N
2903 Error_Msg_N
2920 --------------------------------
2921 -- Check_Implicit_Dereference --
2922 --------------------------------
2929 begin
2932 then
2934 else
2940 then
2945 then
2951 else
2958 -- If the node is a generalized indexing, add interpretation
2959 -- to that node as well, for subsequent resolution.
2965 -- If the operation comes from a generic unit and the context
2966 -- is a selected component, the selector name may be global
2967 -- and set in the instance already. Remove the entity to
2968 -- force resolution of the selected component, and the
2969 -- generation of an explicit dereference if needed.
2971 if In_Instance
2973 then
2985 ----------------------------------
2986 -- Check_Internal_Protected_Use --
2987 ----------------------------------
2993 begin
3001 then
3011 -- An indirect function call (e.g. a callback within a protected
3012 -- function body) is not statically illegal. If the access type is
3013 -- anonymous and is the type of an access parameter, the scope of Nam
3014 -- will be the protected type, but it is not a protected operation.
3017 and then
3019 then
3023 Error_Msg_N
3028 Error_Msg_N
3032 else
3033 Error_Msg_N
3035 Error_Msg_N
3041 ---------------------------------------
3042 -- Check_Later_Vs_Basic_Declarations --
3043 ---------------------------------------
3045 procedure Check_Later_Vs_Basic_Declarations
3048 is
3053 -- Return whether Decl is considered as a declarative item.
3054 -- When During_Parsing is True, the semantics of Ada 83 is followed.
3055 -- When During_Parsing is False, the semantics of SPARK is followed.
3057 -------------------------------
3058 -- Is_Later_Declarative_Item --
3059 -------------------------------
3062 begin
3072 -- In SPARK, a package declaration is not considered as a later
3073 -- declarative item.
3078 -- In SPARK, a renaming is considered as a later declarative item
3083 else
3088 -- Start of processing for Check_Later_Vs_Basic_Declarations
3090 begin
3093 -- Loop through sequence of basic declarative items
3098 then
3101 -- Once a body is encountered, we only allow later declarative
3102 -- items. The inner loop checks the rest of the list.
3104 else
3112 Error_Msg_N
3115 else
3117 Check_SPARK_05_Restriction
3128 ---------------------------
3129 -- Check_No_Hidden_State --
3130 ---------------------------
3134 -- Determine whether the entity of a package denoted by Pkg has a null
3135 -- abstract state.
3137 -----------------------------
3138 -- Has_Null_Abstract_State --
3139 -----------------------------
3144 begin
3145 -- Check first available state of related package. A null abstract
3146 -- state always appears as the sole element of the state list.
3148 return
3153 -- Local variables
3159 -- Start of processing for Check_No_Hidden_State
3161 begin
3164 -- Find the proper context where the object or state appears
3170 -- Keep track of the context's visibility
3174 -- Prevent the search from going too far
3179 -- Objects and states that appear immediately within a subprogram or
3180 -- inside a construct nested within a subprogram do not introduce a
3181 -- hidden state. They behave as local variable declarations.
3186 -- When examining a package body, use the entity of the spec as it
3187 -- carries the abstract state declarations.
3193 -- Stop the traversal when a package subject to a null abstract state
3194 -- has been found.
3198 then
3205 -- At this point we know that there is at least one package with a null
3206 -- abstract state in visibility. Emit an error message unconditionally
3207 -- if the entity being processed is a state because the placement of the
3208 -- related package is irrelevant. This is not the case for objects as
3209 -- the intermediate context matters.
3213 then
3219 ----------------------------------------
3220 -- Check_Nonvolatile_Function_Profile --
3221 ----------------------------------------
3226 begin
3227 -- Inspect all formal parameters
3232 Error_Msg_NE
3240 -- Inspect the return type
3243 Error_Msg_NE
3249 ------------------------------------------
3250 -- Check_Potentially_Blocking_Operation --
3251 ------------------------------------------
3256 begin
3257 -- N is one of the potentially blocking operations listed in 9.5.1(8).
3258 -- When pragma Detect_Blocking is active, the run time will raise
3259 -- Program_Error. Here we only issue a warning, since we generally
3260 -- support the use of potentially blocking operations in the absence
3261 -- of the pragma.
3263 -- Indirect blocking through a subprogram call cannot be diagnosed
3264 -- statically without interprocedural analysis, so we do not attempt
3265 -- to do it here.
3270 Error_Msg_N
3279 ---------------------------------
3280 -- Check_Result_And_Post_State --
3281 ---------------------------------
3284 procedure Check_Result_And_Post_State_In_Pragma
3287 -- Determine whether pragma Prag mentions attribute 'Result and whether
3288 -- the pragma contains an expression that evaluates differently in pre-
3289 -- and post-state. Prag is a [refined] postcondition or a contract-cases
3290 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
3293 -- Determine whether subprogram Subp_Id contains at least one IN OUT
3294 -- formal parameter.
3296 -------------------------------------------
3297 -- Check_Result_And_Post_State_In_Pragma --
3298 -------------------------------------------
3300 procedure Check_Result_And_Post_State_In_Pragma
3303 is
3305 -- Perform the 'Result and post-state checks on a given expression
3308 -- Attempt to find attribute 'Result in a subtree denoted by N
3311 -- Determine whether source node N denotes "True" or "False"
3314 -- Determine whether a subtree denoted by N mentions any construct
3315 -- that denotes a post-state.
3320 ----------------------
3321 -- Check_Expression --
3322 ----------------------
3325 begin
3331 Error_Msg_NE
3336 Error_Msg_NE
3340 else
3341 Error_Msg_NE
3349 ------------------------
3350 -- Is_Function_Result --
3351 ------------------------
3354 begin
3359 -- Continue the traversal
3361 else
3366 ------------------------
3367 -- Is_Trivial_Boolean --
3368 ------------------------
3371 begin
3372 return
3376 or else
3380 -------------------------
3381 -- Mentions_Post_State --
3382 -------------------------
3388 -- Attempt to find a construct that denotes a post-state. If this
3389 -- is the case, set flag Post_State_Seen.
3391 -------------------
3392 -- Is_Post_State --
3393 -------------------
3398 begin
3406 -- The entity may be modifiable through an implicit
3407 -- dereference.
3413 N_Selected_Component)
3414 then
3434 -- Start of processing for Mentions_Post_State
3436 begin
3442 -- Local variables
3445 Get_Pragma_Arg
3450 -- Start of processing for Check_Result_And_Post_State_In_Pragma
3452 begin
3453 -- Examine all consequences
3463 -- Examine the expression of a postcondition
3466 Name_Refined_Post));
3471 --------------------------
3472 -- Has_In_Out_Parameter --
3473 --------------------------
3478 begin
3479 -- Traverse the formals looking for an IN OUT parameter
3493 -- Local variables
3504 -- Start of processing for Check_Result_And_Post_State
3506 begin
3507 -- The lack of attribute 'Result or a post-state is classified as a
3508 -- suspicious contract. Do not perform the check if the corresponding
3509 -- swich is not set.
3514 -- Nothing to do if there is no contract
3520 -- Retrieve the entity of the subprogram spec (if any)
3524 then
3529 then
3532 else
3536 -- Examine all postconditions for attribute 'Result and a post-state
3541 Name_Refined_Post)
3543 then
3551 -- Examine the contract cases of the subprogram for attribute 'Result
3552 -- and a post-state.
3558 then
3566 -- Do not emit any errors if the subprogram is not a function
3571 -- Regardless of whether the function has postconditions or contract
3572 -- cases, or whether they mention attribute 'Result, an IN OUT formal
3573 -- parameter is always treated as a result.
3578 -- The function has both a postcondition and contract cases and they do
3579 -- not mention attribute 'Result.
3582 and then not Seen_In_Case
3584 and then not Seen_In_Post
3585 then
3586 Error_Msg_N
3590 -- The function has contract cases only and they do not mention
3591 -- attribute 'Result.
3596 -- The function has postconditions only and they do not mention
3597 -- attribute 'Result.
3600 Error_Msg_N
3605 ------------------------------
3606 -- Check_Unprotected_Access --
3607 ------------------------------
3609 procedure Check_Unprotected_Access
3612 is
3617 -- Check whether Obj is a private component of a protected object.
3618 -- Return the protected type where the component resides, Empty
3619 -- otherwise.
3622 -- Verify that the enclosing operation is callable from outside the
3623 -- protected object, to minimize false positives.
3625 ------------------------------
3626 -- Enclosing_Protected_Type --
3627 ------------------------------
3630 begin
3632 declare
3635 begin
3636 -- The object can be a renaming of a private component, use
3637 -- the original record component.
3649 -- For indexed and selected components, recursively check the prefix
3654 -- The object does not denote a protected component
3656 else
3661 -------------------------
3662 -- Is_Public_Operation --
3663 -------------------------
3669 begin
3676 loop
3691 -- Start of processing for Check_Unprotected_Access
3693 begin
3696 then
3700 -- Check whether we are trying to export a protected component to a
3701 -- context with an equal or lower access level.
3705 and then Is_Public_Operation
3708 then
3709 Error_Msg_N
3715 ------------------------------
3716 -- Check_Unused_Body_States --
3717 ------------------------------
3720 procedure Process_Refinement_Clause
3723 -- Inspect all constituents of refinement clause Clause and remove any
3724 -- matches from body state list States.
3727 -- Emit errors for each abstract state or object found in list States
3729 -------------------------------
3730 -- Process_Refinement_Clause --
3731 -------------------------------
3733 procedure Process_Refinement_Clause
3736 is
3738 -- Remove constituent Constit from body state list States
3740 -------------------------
3741 -- Process_Constituent --
3742 -------------------------
3747 begin
3748 -- Guard against illegal constituents. Only abstract states and
3749 -- objects can appear on the right hand side of a refinement.
3756 E_Constant,
3757 E_Variable)
3758 then
3764 -- Local variables
3768 -- Start of processing for Process_Refinement_Clause
3770 begin
3774 -- Multiple constituents appear as an aggregate
3783 -- Various forms of a single constituent
3785 else
3791 -------------------------------
3792 -- Report_Unused_Body_States --
3793 -------------------------------
3800 begin
3806 -- Constants are part of the hidden state of a package, but the
3807 -- compiler cannot determine whether they have variable input
3808 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
3809 -- hidden state. Do not emit an error when a constant does not
3810 -- participate in a state refinement, even though it acts as a
3811 -- hidden state.
3816 -- Generate an error message of the form:
3818 -- body of package ... has unused hidden states
3819 -- abstract state ... defined at ...
3820 -- variable ... defined at ...
3822 else
3825 SPARK_Msg_N
3832 SPARK_Msg_NE
3835 else
3845 -- Local variables
3852 -- Start of processing for Check_Unused_Body_States
3854 begin
3855 -- Inspect the clauses of pragma Refined_State and determine whether all
3856 -- visible states declared within the package body participate in the
3857 -- refinement.
3863 -- Multiple non-null state refinements appear as an aggregate
3872 -- Various forms of a single state refinement
3874 else
3878 -- Ensure that all abstract states and objects declared in the
3879 -- package body state space are utilized as constituents.
3885 -------------------------
3886 -- Collect_Body_States --
3887 -------------------------
3891 -- Determine whether object Obj_Id is a suitable visible state of a
3892 -- package body.
3894 procedure Collect_Visible_States
3897 -- Gather the entities of all abstract states and objects declared in
3898 -- the visible state space of package Pack_Id.
3900 ----------------------------
3901 -- Collect_Visible_States --
3902 ----------------------------
3904 procedure Collect_Visible_States
3907 is
3910 begin
3911 -- Traverse the entity chain of the package and inspect all visible
3912 -- items.
3917 -- Do not consider internally generated items as those cannot be
3918 -- named and participate in refinement.
3928 then
3931 -- Recursively gather the visible states of a nested package
3941 -----------------------
3942 -- Is_Visible_Object --
3943 -----------------------
3946 begin
3947 -- Objects that map generic formals to their actuals are not visible
3948 -- from outside the generic instantiation.
3952 then
3955 -- Constituents of a single protected/task type act as components of
3956 -- the type and are not visible from outside the type.
3961 then
3964 else
3969 -- Local variables
3976 -- Start of processing for Collect_Body_States
3978 begin
3979 -- Inspect the declarations of the body looking for source objects,
3980 -- packages and package instantiations. Note that even though this
3981 -- processing is very similar to Collect_Visible_States, a package
3982 -- body does not have a First/Next_Entity list.
3987 -- Capture source objects as internally generated temporaries cannot
3988 -- be named and participate in refinement.
3995 then
3999 -- Capture the visible abstract states and objects of a source
4000 -- package [instantiation].
4016 ------------------------
4017 -- Collect_Interfaces --
4018 ------------------------
4020 procedure Collect_Interfaces
4025 is
4027 -- Subsidiary subprogram used to traverse the whole list
4028 -- of directly and indirectly implemented interfaces
4030 -------------
4031 -- Collect --
4032 -------------
4040 begin
4043 -- Handle private types and subtypes
4045 if Use_Full_View
4048 then
4056 -- Include the ancestor if we are generating the whole list of
4057 -- abstract interfaces.
4061 -- Protect the frontend against wrong sources. For example:
4063 -- package P is
4064 -- type A is tagged null record;
4065 -- type B is new A with private;
4066 -- type C is new A with private;
4067 -- private
4068 -- type B is new C with null record;
4069 -- type C is new B with null record;
4070 -- end P;
4073 then
4082 -- Traverse the graph of ancestor interfaces
4089 -- Protect against wrong uses. For example:
4090 -- type I is interface;
4091 -- type O is tagged null record;
4092 -- type Wrong is new I and O with null record; -- ERROR
4095 if Exclude_Parents
4098 then
4100 else
4111 -- Start of processing for Collect_Interfaces
4113 begin
4119 ----------------------------------
4120 -- Collect_Interface_Components --
4121 ----------------------------------
4123 procedure Collect_Interface_Components
4126 is
4128 -- Subsidiary subprogram used to climb to the parents
4130 -------------
4131 -- Collect --
4132 -------------
4138 begin
4139 -- Handle private types
4143 else
4149 -- Protect the frontend against wrong sources. For example:
4151 -- package P is
4152 -- type A is tagged null record;
4153 -- type B is new A with private;
4154 -- type C is new A with private;
4155 -- private
4156 -- type B is new C with null record;
4157 -- type C is new B with null record;
4158 -- end P;
4161 then
4165 -- Collect the components containing tags of secondary dispatch
4166 -- tables.
4177 -- Start of processing for Collect_Interface_Components
4179 begin
4187 -----------------------------
4188 -- Collect_Interfaces_Info --
4189 -----------------------------
4191 procedure Collect_Interfaces_Info
4196 is
4204 -- Search for the secondary tag associated with the interface type
4205 -- Iface that is implemented by T.
4207 ----------------
4208 -- Search_Tag --
4209 ----------------
4213 begin
4216 else
4223 loop
4224 -- Skip secondary dispatch table referencing thunks to user
4225 -- defined primitives covered by this interface.
4230 -- Skip secondary dispatch tables of Ada types
4234 -- Skip secondary dispatch table referencing thunks to
4235 -- predefined primitives.
4240 -- Skip secondary dispatch table referencing user-defined
4241 -- primitives covered by this interface.
4246 -- Skip secondary dispatch table referencing predefined
4247 -- primitives.
4258 -- Start of processing for Collect_Interfaces_Info
4260 begin
4264 -- Search for the record component and tag associated with each
4265 -- interface type of T.
4274 -- Associate the primary tag component and the primary dispatch table
4275 -- with all the interfaces that are parents of T
4281 -- Otherwise search for the tag component and secondary dispatch
4282 -- table of Iface
4284 else
4291 then
4306 ---------------------
4307 -- Collect_Parents --
4308 ---------------------
4310 procedure Collect_Parents
4314 is
4318 begin
4321 -- No action if the if the type has no parents
4327 loop
4332 and then Use_Full_View
4333 then
4344 ----------------------------------
4345 -- Collect_Primitive_Operations --
4346 ----------------------------------
4360 -- True if E's base type is B_Type, or E is of an anonymous access type
4361 -- and the base type of its designated type is B_Type.
4363 -----------
4364 -- Match --
4365 -----------
4370 begin
4375 -- In Ada 2012 a primitive operation may have a formal of an
4376 -- incomplete view of the parent type.
4379 or else
4385 -- Start of processing for Collect_Primitive_Operations
4387 begin
4388 -- For tagged types, the primitive operations are collected as they
4389 -- are declared, and held in an explicit list which is simply returned.
4394 -- An untagged generic type that is a derived type inherits the
4395 -- primitive operations of its parent type. Other formal types only
4396 -- have predefined operators, which are not explicitly represented.
4401 N_Formal_Derived_Type_Definition
4402 then
4404 else
4418 else
4422 -- Locate the primitive subprograms of the type
4424 else
4425 -- The primitive operations appear after the base type, except
4426 -- if the derivation happens within the private part of B_Scope
4427 -- and the type is a private type, in which case both the type
4428 -- and some primitive operations may appear before the base
4429 -- type, and the list of candidates starts after the type.
4434 then
4437 -- In Ada 2012, If the type has an incomplete partial view, there
4438 -- may be primitive operations declared before the full view, so
4439 -- we need to start scanning from the incomplete view, which is
4440 -- earlier on the entity chain.
4444 then
4447 -- If T is a derived from a type with an incomplete view declared
4448 -- elsewhere, that incomplete view is irrelevant, we want the
4449 -- operations in the scope of T.
4455 else
4459 -- Set flag if this is a type in a package spec
4461 Is_Type_In_Pkg :=
4463 and then
4465 N_Package_Body;
4469 -- Test whether the result type or any of the parameter types of
4470 -- each subprogram following the type match that type when the
4471 -- type is declared in a package spec, is a derived type, or the
4472 -- subprogram is marked as primitive. (The Is_Primitive test is
4473 -- needed to find primitives of nonderived types in declarative
4474 -- parts that happen to override the predefined "=" operator.)
4476 -- Note that generic formal subprograms are not considered to be
4477 -- primitive operations and thus are never inherited.
4484 not in N_Formal_Subprogram_Declaration
4485 then
4491 else
4503 -- For a formal derived type, the only primitives are the ones
4504 -- inherited from the parent type. Operations appearing in the
4505 -- package declaration are not primitive for it.
4507 if Is_Prim
4509 then
4510 -- In the special case of an equality operator aliased to
4511 -- an overriding dispatching equality belonging to the same
4512 -- type, we don't include it in the list of primitives.
4513 -- This avoids inheriting multiple equality operators when
4514 -- deriving from untagged private types whose full type is
4515 -- tagged, which can otherwise cause ambiguities. Note that
4516 -- this should only happen for this kind of untagged parent
4517 -- type, since normally dispatching operations are inherited
4518 -- using the type's Primitive_Operations list.
4526 then
4529 -- Include the subprogram in the list of primitives
4531 else
4539 -- For a type declared in System, some of its operations may
4540 -- appear in the target-specific extension to System.
4544 and then Present_System_Aux
4545 then
4555 -----------------------------------
4556 -- Compile_Time_Constraint_Error --
4557 -----------------------------------
4559 function Compile_Time_Constraint_Error
4565 is
4567 -- Copy of message, with room for possible ?? or << and ! at end
4573 -- Start of processing for Compile_Time_Constraint_Error
4575 begin
4576 -- If this is a warning, convert it into an error if we are in code
4577 -- subject to SPARK_Mode being set ON.
4581 -- A static constraint error in an instance body is not a fatal error.
4582 -- we choose to inhibit the message altogether, because there is no
4583 -- obvious node (for now) on which to post it. On the other hand the
4584 -- offending node must be replaced with a constraint_error in any case.
4586 -- No messages are generated if we already posted an error on this node
4591 else
4595 -- Copy message to Msgc, converting any ? in the message into
4596 -- < instead, so that we have an error in GNATprove mode.
4603 else
4608 -- Message is a warning, even in Ada 95 case
4613 -- In Ada 83, all messages are warnings. In the private part and
4614 -- the body of an instance, constraint_checks are only warnings.
4615 -- We also make this a warning if the Warn parameter is set.
4617 elsif Warn
4619 then
4633 -- Otherwise we have a real error message (Ada 95 static case)
4634 -- and we make this an unconditional message. Note that in the
4635 -- warning case we do not make the message unconditional, it seems
4636 -- quite reasonable to delete messages like this (about exceptions
4637 -- that will be raised) in dead code.
4639 else
4645 -- One more test, skip the warning if the related expression is
4646 -- statically unevaluated, since we don't want to warn about what
4647 -- will happen when something is evaluated if it never will be
4648 -- evaluated.
4655 else
4661 -- Check whether the context is an Init_Proc
4664 declare
4666 Corresponding_Concurrent_Type
4668 (Parameter_Specifications
4671 begin
4672 -- Don't complain if the corresponding concurrent type
4673 -- doesn't come from source (i.e. a single task/protected
4674 -- object).
4678 then
4679 Error_Msg_NEL
4682 else
4684 Error_Msg_NEL
4687 else
4688 Error_Msg_NEL
4695 else
4699 else
4709 -----------------------
4710 -- Conditional_Delay --
4711 -----------------------
4714 begin
4720 ----------------------------
4721 -- Contains_Refined_State --
4722 ----------------------------
4726 -- Determine whether a dependency list mentions a state with a visible
4727 -- refinement.
4730 -- Determine whether a global list mentions a state with a visible
4731 -- refinement.
4734 -- Determine whether Item is a reference to an abstract state with a
4735 -- visible refinement.
4737 -----------------------------
4738 -- Has_State_In_Dependency --
4739 -----------------------------
4745 begin
4746 -- A null dependency list does not mention any states
4751 -- Dependency clauses appear as component associations of an
4752 -- aggregate.
4756 then
4760 -- Inspect the outputs of a dependency clause
4771 -- Inspect the outputs of a dependency clause
4780 -- If we get here, then none of the dependency clauses mention a
4781 -- state with visible refinement.
4785 -- An illegal pragma managed to sneak in
4787 else
4792 -------------------------
4793 -- Has_State_In_Global --
4794 -------------------------
4799 begin
4800 -- A null global list does not mention any states
4805 -- Simple global list or moded global list declaration
4809 -- The declaration of a simple global list appear as a collection
4810 -- of expressions.
4822 -- The declaration of a moded global list appears as a collection
4823 -- of component associations where individual choices denote
4824 -- modes.
4826 else
4837 -- If we get here, then the simple/moded global list did not
4838 -- mention any states with a visible refinement.
4842 -- Single global item declaration
4847 -- An illegal pragma managed to sneak in
4849 else
4854 ----------------------
4855 -- Is_Refined_State --
4856 ----------------------
4862 begin
4866 -- States cannot be subject to attribute 'Result. This case arises
4867 -- in dependency relations.
4871 then
4874 -- Multiple items appear as an aggregate. This case arises in
4875 -- dependency relations.
4879 then
4889 -- If we get here, then none of the inputs or outputs reference a
4890 -- state with visible refinement.
4894 -- Single item
4896 else
4899 return
4906 -- Local variables
4912 -- Start of processing for Contains_Refined_State
4914 begin
4923 -------------------------
4924 -- Copy_Component_List --
4925 -------------------------
4927 function Copy_Component_List
4930 is
4934 begin
4938 declare
4940 begin
4943 Defining_Identifier =>
4945 Component_Definition =>
4946 New_Copy_Tree
4957 -------------------------
4958 -- Copy_Parameter_List --
4959 -------------------------
4966 begin
4969 else
4975 Defining_Identifier =>
4979 Parameter_Type =>
4981 Expression =>
4991 --------------------------
4992 -- Copy_Subprogram_Spec --
4993 --------------------------
5000 begin
5001 -- The structure of the original tree must be replicated without any
5002 -- alterations. Use New_Copy_Tree for this purpose.
5006 -- Create a new entity for the defining unit name
5012 -- Create new entities for the formal parameters
5028 --------------------------------
5029 -- Corresponding_Generic_Type --
5030 --------------------------------
5037 begin
5041 -- If the actual is the actual of an enclosing instance, resolution
5042 -- was correct in the generic.
5046 and then
5048 then
5051 else
5058 Gen :=
5059 Generic_Parent
5062 -- Generic actual has the same name as the corresponding formal
5077 --------------------
5078 -- Current_Entity --
5079 --------------------
5081 -- The currently visible definition for a given identifier is the
5082 -- one most chained at the start of the visibility chain, i.e. the
5083 -- one that is referenced by the Node_Id value of the name of the
5084 -- given identifier.
5087 begin
5091 -----------------------------
5092 -- Current_Entity_In_Scope --
5093 -----------------------------
5101 begin
5106 loop
5113 -------------------
5114 -- Current_Scope --
5115 -------------------
5118 begin
5121 else
5122 declare
5125 begin
5128 else
5135 ------------------------
5136 -- Current_Subprogram --
5137 ------------------------
5141 begin
5144 else
5149 ----------------------------------
5150 -- Deepest_Type_Access_Level --
5151 ----------------------------------
5154 begin
5158 then
5159 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
5160 -- access type.
5162 return
5163 Scope_Depth (Enclosing_Dynamic_Scope
5164 (Defining_Identifier
5167 -- For generic formal type, return Int'Last (infinite).
5168 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
5173 else
5178 ---------------------
5179 -- Defining_Entity --
5180 ---------------------
5182 function Defining_Entity
5185 is
5188 begin
5190 when N_Abstract_Subprogram_Declaration |
5191 N_Expression_Function |
5192 N_Formal_Subprogram_Declaration |
5193 N_Generic_Package_Declaration |
5194 N_Generic_Subprogram_Declaration |
5195 N_Package_Declaration |
5196 N_Subprogram_Body |
5197 N_Subprogram_Body_Stub |
5198 N_Subprogram_Declaration |
5199 N_Subprogram_Renaming_Declaration
5200 =>
5203 when N_Component_Declaration |
5204 N_Defining_Program_Unit_Name |
5205 N_Discriminant_Specification |
5206 N_Entry_Body |
5207 N_Entry_Declaration |
5208 N_Entry_Index_Specification |
5209 N_Exception_Declaration |
5210 N_Exception_Renaming_Declaration |
5211 N_Formal_Object_Declaration |
5212 N_Formal_Package_Declaration |
5213 N_Formal_Type_Declaration |
5214 N_Full_Type_Declaration |
5215 N_Implicit_Label_Declaration |
5216 N_Incomplete_Type_Declaration |
5217 N_Loop_Parameter_Specification |
5218 N_Number_Declaration |
5219 N_Object_Declaration |
5220 N_Object_Renaming_Declaration |
5221 N_Package_Body_Stub |
5222 N_Parameter_Specification |
5223 N_Private_Extension_Declaration |
5224 N_Private_Type_Declaration |
5225 N_Protected_Body |
5226 N_Protected_Body_Stub |
5227 N_Protected_Type_Declaration |
5228 N_Single_Protected_Declaration |
5229 N_Single_Task_Declaration |
5230 N_Subtype_Declaration |
5231 N_Task_Body |
5232 N_Task_Body_Stub |
5233 N_Task_Type_Declaration
5234 =>
5240 when N_Function_Instantiation |
5241 N_Function_Specification |
5242 N_Generic_Function_Renaming_Declaration |
5243 N_Generic_Package_Renaming_Declaration |
5244 N_Generic_Procedure_Renaming_Declaration |
5245 N_Package_Body |
5246 N_Package_Instantiation |
5247 N_Package_Renaming_Declaration |
5248 N_Package_Specification |
5249 N_Procedure_Instantiation |
5250 N_Procedure_Specification
5251 =>
5252 declare
5255 begin
5259 -- For Error, make up a name and attach to declaration so we
5260 -- can continue semantic analysis.
5265 else
5272 -- If not an entity, get defining identifier
5274 else
5279 when N_Block_Statement |
5280 N_Loop_Statement =>
5286 else
5293 --------------------------
5294 -- Denotes_Discriminant --
5295 --------------------------
5297 function Denotes_Discriminant
5300 is
5303 begin
5306 else
5310 -- If we are checking for a protected type, the discriminant may have
5311 -- been rewritten as the corresponding discriminal of the original type
5312 -- or of the corresponding concurrent record, depending on whether we
5313 -- are in the spec or body of the protected type.
5316 or else
5317 (Check_Concurrent
5320 and then
5322 or else
5326 -------------------------
5327 -- Denotes_Same_Object --
5328 -------------------------
5335 -- Return True if N has attribute Prefix
5338 -- Return true if N names a renaming entity
5341 -- For renamings, return False if the prefix of any dereference within
5342 -- the renamed object_name is a variable, or any expression within the
5343 -- renamed object_name contains references to variables or calls on
5344 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
5346 ----------------
5347 -- Has_Prefix --
5348 ----------------
5351 begin
5352 return
5354 N_Attribute_Reference,
5355 N_Expanded_Name,
5356 N_Explicit_Dereference,
5357 N_Indexed_Component,
5358 N_Reference,
5359 N_Selected_Component,
5360 N_Slice);
5363 -----------------
5364 -- Is_Renaming --
5365 -----------------
5368 begin
5373 -----------------------
5374 -- Is_Valid_Renaming --
5375 -----------------------
5380 -- Recursive function used to traverse all the prefixes of N
5383 begin
5386 then
5391 declare
5394 begin
5407 declare
5410 begin
5413 then
5418 then
5425 -- Recursion to continue traversing the prefix of the
5426 -- renaming expression
5435 -- Start of processing for Is_Valid_Renaming
5437 begin
5441 -- Start of processing for Denotes_Same_Object
5443 begin
5444 -- Both names statically denote the same stand-alone object or parameter
5445 -- (RM 6.4.1(6.5/3))
5450 then
5454 -- For renamings, the prefix of any dereference within the renamed
5455 -- object_name is not a variable, and any expression within the
5456 -- renamed object_name contains no references to variables nor
5457 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
5462 else
5470 else
5475 -- No match if not same node kind (such cases are handled by
5476 -- Denotes_Same_Prefix)
5481 -- After handling valid renamings, one of the two names statically
5482 -- denoted a renaming declaration whose renamed object_name is known
5483 -- to denote the same object as the other (RM 6.4.1(6.10/3))
5488 else
5492 -- Both names are selected_components, their prefixes are known to
5493 -- denote the same object, and their selector_names denote the same
5494 -- component (RM 6.4.1(6.6/3)).
5498 and then
5501 -- Both names are dereferences and the dereferenced names are known to
5502 -- denote the same object (RM 6.4.1(6.7/3))
5507 -- Both names are indexed_components, their prefixes are known to denote
5508 -- the same object, and each of the pairs of corresponding index values
5509 -- are either both static expressions with the same static value or both
5510 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
5515 else
5516 declare
5520 begin
5525 -- Indexes must denote the same static value or same object
5547 -- Both names are slices, their prefixes are known to denote the same
5548 -- object, and the two slices have statically matching index constraints
5549 -- (RM 6.4.1(6.9/3))
5553 then
5554 declare
5557 begin
5561 -- Check whether bounds are statically identical. There is no
5562 -- attempt to detect partial overlap of slices.
5565 and then
5569 -- In the recursion, literals appear as indexes
5572 and then
5574 then
5577 else
5582 -------------------------
5583 -- Denotes_Same_Prefix --
5584 -------------------------
5587 begin
5591 then
5594 else
5602 and then
5604 then
5605 declare
5609 begin
5612 if not Nkind_In
5614 then
5616 else
5626 N_Indexed_Component)
5627 then
5629 else
5636 -- If both have the same depth and they do not denote the same
5637 -- object, they are disjoint and no warning is needed.
5650 else
5660 else
5665 ----------------------
5666 -- Denotes_Variable --
5667 ----------------------
5670 begin
5674 -----------------------------
5675 -- Depends_On_Discriminant --
5676 -----------------------------
5682 begin
5687 -------------------------
5688 -- Designate_Same_Unit --
5689 -------------------------
5691 function Designate_Same_Unit
5694 is
5699 -- Returns the parent unit name node of a defining program unit name
5700 -- or the prefix if N is a selected component or an expanded name.
5703 -- Returns the defining identifier node of a defining program unit
5704 -- name or the selector node if N is a selected component or an
5705 -- expanded name.
5707 -----------------
5708 -- Prefix_Node --
5709 -----------------
5712 begin
5715 else
5720 -----------------
5721 -- Select_Node --
5722 -----------------
5725 begin
5728 else
5733 -- Start of processing for Designate_Same_Unit
5735 begin
5737 and then
5739 then
5743 N_Selected_Component,
5744 N_Defining_Program_Unit_Name)
5745 and then
5747 N_Selected_Component,
5748 N_Defining_Program_Unit_Name)
5749 then
5750 return
5752 and then
5755 else
5760 ------------------------------------------
5761 -- function Dynamic_Accessibility_Level --
5762 ------------------------------------------
5769 -- Construct an integer literal representing an accessibility level
5770 -- with its type set to Natural.
5772 ------------------------
5773 -- Make_Level_Literal --
5774 ------------------------
5778 begin
5783 -- Start of processing for Dynamic_Accessibility_Level
5785 begin
5800 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
5804 -- For access discriminant, the level of the enclosing object
5809 E_Anonymous_Access_Type
5810 then
5817 -- For X'Access, the level of the prefix X
5820 return Make_Level_Literal
5823 -- Treat the unchecked attributes as library-level
5825 when Attribute_Unchecked_Access |
5826 Attribute_Unrestricted_Access =>
5829 -- No other access-valued attributes
5837 -- Unimplemented: depends on context. As an actual parameter where
5838 -- formal type is anonymous, use
5839 -- Scope_Depth (Current_Scope) + 1.
5840 -- For other cases, see 3.10.2(14/3) and following. ???
5847 -- Handle type conversions introduced for a rename of an
5848 -- Ada 2012 stand-alone object of an anonymous access type.
5860 -----------------------------------
5861 -- Effective_Extra_Accessibility --
5862 -----------------------------------
5865 begin
5868 then
5870 else
5875 -----------------------------
5876 -- Effective_Reads_Enabled --
5877 -----------------------------
5880 begin
5884 ------------------------------
5885 -- Effective_Writes_Enabled --
5886 ------------------------------
5889 begin
5893 ------------------------------
5894 -- Enclosing_Comp_Unit_Node --
5895 ------------------------------
5900 begin
5904 loop
5910 else
5915 --------------------------
5916 -- Enclosing_CPP_Parent --
5917 --------------------------
5922 begin
5925 loop
5937 ---------------------------
5938 -- Enclosing_Declaration --
5939 ---------------------------
5944 begin
5947 or else
5949 loop
5956 ----------------------------
5957 -- Enclosing_Generic_Body --
5958 ----------------------------
5960 function Enclosing_Generic_Body
5962 is
5967 begin
5972 then
5980 then
5992 ----------------------------
5993 -- Enclosing_Generic_Unit --
5994 ----------------------------
5996 function Enclosing_Generic_Unit
5998 is
6003 begin
6008 then
6013 then
6021 then
6033 -------------------------------
6034 -- Enclosing_Lib_Unit_Entity --
6035 -------------------------------
6037 function Enclosing_Lib_Unit_Entity
6039 is
6042 begin
6043 -- Look for enclosing library unit entity by following scope links.
6044 -- Equivalent to, but faster than indexing through the scope stack.
6050 loop
6057 -----------------------------
6058 -- Enclosing_Lib_Unit_Node --
6059 -----------------------------
6064 begin
6068 loop
6075 -----------------------
6076 -- Enclosing_Package --
6077 -----------------------
6082 begin
6090 E_Generic_Package)
6091 then
6094 else
6099 -------------------------------------
6100 -- Enclosing_Package_Or_Subprogram --
6101 -------------------------------------
6106 begin
6111 then
6116 then
6119 else
6127 --------------------------
6128 -- Enclosing_Subprogram --
6129 --------------------------
6134 begin
6146 then
6155 then
6158 -- No body is generated if the protected operation is eliminated
6163 then
6166 else
6171 ------------------------
6172 -- Ensure_Freeze_Node --
6173 ------------------------
6177 begin
6188 ----------------
6189 -- Enter_Name --
6190 ----------------
6197 begin
6200 -- Add new name to current scope declarations. Check for duplicate
6201 -- declaration, which may or may not be a genuine error.
6205 -- Case of previous entity entered because of a missing declaration
6206 -- or else a bad subtype indication. Best is to use the new entity,
6207 -- and make the previous one invisible.
6212 -- Case of renaming declaration constructed for package instances.
6213 -- if there is an explicit declaration with the same identifier,
6214 -- the renaming is not immediately visible any longer, but remains
6215 -- visible through selected component notation.
6219 then
6222 -- The new entity may be the package renaming, which has the same
6223 -- same name as a generic formal which has been seen already.
6227 then
6230 -- For a fat pointer corresponding to a remote access to subprogram,
6231 -- we use the same identifier as the RAS type, so that the proper
6232 -- name appears in the stub. This type is only retrieved through
6233 -- the RAS type and never by visibility, and is not added to the
6234 -- visibility list (see below).
6239 then
6242 -- Case of an implicit operation or derived literal. The new entity
6243 -- hides the implicit one, which is removed from all visibility,
6244 -- i.e. the entity list of its scope, and homonym chain of its name.
6248 then
6249 declare
6254 begin
6255 -- If E is an implicit declaration, it cannot be the first
6256 -- entity in the scope.
6265 -- If E is not on the entity chain of the current scope,
6266 -- it is an implicit declaration in the generic formal
6267 -- part of a generic subprogram. When analyzing the body,
6268 -- the generic formals are visible but not on the entity
6269 -- chain of the subprogram. The new entity will become
6270 -- the visible one in the body.
6272 pragma Assert
6276 else
6286 else
6295 -- Skip E in the visibility chain
6299 else
6305 -- This section of code could use a comment ???
6310 then
6313 -- If the homograph is a protected component renaming, it should not
6314 -- be hiding the current entity. Such renamings are treated as weak
6315 -- declarations.
6320 -- In this case the current entity is a protected component renaming.
6321 -- Perform minimal decoration by setting the scope and return since
6322 -- the prival should not be hiding other visible entities.
6328 -- Analogous to privals, the discriminal generated for an entry index
6329 -- parameter acts as a weak declaration. Perform minimal decoration
6330 -- to avoid bogus errors.
6334 then
6338 -- In the body or private part of an instance, a type extension may
6339 -- introduce a component with the same name as that of an actual. The
6340 -- legality rule is not enforced, but the semantics of the full type
6341 -- with two components of same name are not clear at this point???
6346 -- When compiling a package body, some child units may have become
6347 -- visible. They cannot conflict with local entities that hide them.
6352 then
6355 -- Conversely, with front-end inlining we may compile the parent body
6356 -- first, and a child unit subsequently. The context is now the
6357 -- parent spec, and body entities are not visible.
6362 then
6365 -- Case of genuine duplicate declaration
6367 else
6370 -- If the previous declaration is an incomplete type declaration
6371 -- this may be an attempt to complete it with a private type. The
6372 -- following avoids confusing cascaded errors.
6376 then
6377 Error_Msg_N
6383 -- An inherited component of a record conflicts with a new
6384 -- discriminant. The discriminant is inserted first in the scope,
6385 -- but the error should be posted on it, not on the component.
6390 then
6395 -- If the name of the unit appears in its own context clause, a
6396 -- dummy package with the name has already been created, and the
6397 -- error emitted. Try to continue quietly.
6403 then
6407 else
6410 -- Avoid cascaded messages with duplicate components in
6411 -- derived types.
6419 N_Generic_Subprogram_Declaration
6422 then
6426 -- If entity is in standard, then we are in trouble, because it
6427 -- means that we have a library package with a duplicated name.
6428 -- That's hard to recover from, so abort.
6433 -- Otherwise we continue with the declaration. Having two
6434 -- identical declarations should not cause us too much trouble.
6436 else
6442 -- If we fall through, declaration is OK, at least OK enough to continue
6444 -- If Def_Id is a discriminant or a record component we are in the midst
6445 -- of inheriting components in a derived record definition. Preserve
6446 -- their Ekind and Etype.
6451 -- If a type is already set, leave it alone (happens when a type
6452 -- declaration is reanalyzed following a call to the optimizer).
6457 -- Otherwise, the kind E_Void insures that premature uses of the entity
6458 -- will be detected. Any_Type insures that no cascaded errors will occur
6460 else
6465 -- Inherited discriminants and components in derived record types are
6466 -- immediately visible. Itypes are not.
6468 -- Unless the Itype is for a record type with a corresponding remote
6469 -- type (what is that about, it was not commented ???)
6472 or else
6476 then
6485 -- Declaring a homonym is not allowed in SPARK ...
6488 declare
6493 begin
6494 -- ... unless the new declaration is in a subprogram, and the
6495 -- visible declaration is a variable declaration or a parameter
6496 -- specification outside that subprogram.
6500 N_Parameter_Specification)
6502 then
6505 -- ... or the new declaration is in a package, and the visible
6506 -- declaration occurs outside that package.
6510 then
6513 -- ... or the new declaration is a component declaration in a
6514 -- record type definition.
6519 -- Don't issue error for non-source entities
6523 then
6525 Check_SPARK_05_Restriction
6531 -- Warn if new entity hides an old one
6535 -- Don't warn for record components since they always have a well
6536 -- defined scope which does not confuse other uses. Note that in
6537 -- some cases, Ekind has not been set yet.
6546 -- Don't warn for one character variables. It is too common to use
6547 -- such variables as locals and will just cause too many false hits.
6551 -- Don't warn for non-source entities
6556 -- Don't warn unless entity in question is in extended main source
6560 -- Finally, the hidden entity must be either immediately visible or
6561 -- use visible (i.e. from a used package).
6563 and then
6565 or else
6567 then
6573 ---------------
6574 -- Entity_Of --
6575 ---------------
6580 begin
6586 -- Follow a possible chain of renamings to reach the root renamed
6587 -- object.
6592 loop
6595 else
6605 --------------------------
6606 -- Explain_Limited_Type --
6607 --------------------------
6612 begin
6613 -- For array, component type must be limited
6617 Error_Msg_NE
6623 -- No need for extra messages if explicit limited record
6629 -- Otherwise find a limited component. Check only components that
6630 -- come from source, or inherited components that appear in the
6631 -- source of the ancestor.
6636 and then
6638 or else
6640 and then
6642 then
6652 -- The type may be declared explicitly limited, even if no component
6653 -- of it is limited, in which case we fall out of the loop.
6658 -------------------------------
6659 -- Extensions_Visible_Status --
6660 -------------------------------
6662 function Extensions_Visible_Status
6664 is
6671 begin
6672 -- When a formal parameter is subject to Extensions_Visible, the pragma
6673 -- is stored in the contract of related subprogram.
6681 -- No other construct carries this pragma
6683 else
6689 -- In certain cases analysis may request the Extensions_Visible status
6690 -- of an expression function before the pragma has been analyzed yet.
6691 -- Inspect the declarative items after the expression function looking
6692 -- for the pragma (if any).
6699 then
6703 -- A source construct ends the region where Extensions_Visible may
6704 -- appear, stop the traversal. An expanded expression function is
6705 -- no longer a source construct, but it must still be recognized.
6708 or else
6710 N_Subprogram_Declaration)
6712 then
6720 -- Extract the value from the Boolean expression (if any)
6728 -- When the associated subprogram is an expression function, the
6729 -- argument of the pragma may not have been analyzed.
6735 -- Guard against cascading errors when the argument of pragma
6736 -- Extensions_Visible is not a valid static Boolean expression.
6744 else
6748 -- Otherwise the aspect or pragma defaults to True
6750 else
6754 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
6755 -- directly specified. In SPARK code, its value defaults to "False".
6760 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
6761 -- "True".
6763 else
6768 -----------------
6769 -- Find_Actual --
6770 -----------------
6772 procedure Find_Actual
6776 is
6781 begin
6784 then
6790 then
6794 N_Function_Call,
6795 N_Procedure_Call_Statement)
6796 then
6799 else
6805 -- If we have a call to a subprogram look for the parameter. Note that
6806 -- we exclude overloaded calls, since we don't know enough to be sure
6807 -- of giving the right answer in this case.
6810 N_Function_Call,
6811 N_Procedure_Call_Statement)
6812 then
6815 -- A call to a protected or task entry appears as a selected
6816 -- component rather than an expanded name.
6826 then
6827 -- If node is name in call it is not an actual
6835 -- Fall here if we are definitely a parameter
6843 -- An actual that is the prefix in a prefixed call may have
6844 -- been rewritten in the call, after the deferred reference
6845 -- was collected. Check if sloc and kinds and names match.
6851 then
6854 else
6862 -- Fall through here if we did not find matching actual
6868 ---------------------------
6869 -- Find_Body_Discriminal --
6870 ---------------------------
6872 function Find_Body_Discriminal
6874 is
6878 begin
6879 -- If expansion is suppressed, then the scope can be the concurrent type
6880 -- itself rather than a corresponding concurrent record type.
6885 else
6891 -- Find discriminant of original concurrent type, and use its current
6892 -- discriminal, which is the renaming within the task/protected body.
6903 -- That loop should always succeed in finding a matching entry and
6904 -- returning. Fatal error if not.
6909 -------------------------------------
6910 -- Find_Corresponding_Discriminant --
6911 -------------------------------------
6913 function Find_Corresponding_Discriminant
6916 is
6921 begin
6924 -- The original type may currently be private, and the discriminant
6925 -- only appear on its full view.
6930 then
6932 else
6938 else
6951 -- Should always find it
6956 ----------------------------------
6957 -- Find_Enclosing_Iterator_Loop --
6958 ----------------------------------
6964 begin
6965 -- Traverse the scope chain looking for an iterator loop. Such loops are
6966 -- usually transformed into blocks, hence the use of Original_Node.
6972 then
6979 N_Iterator_Specification
6980 then
6991 ------------------------------------
6992 -- Find_Loop_In_Conditional_Block --
6993 ------------------------------------
6998 begin
7007 -- Inspect the statements of the conditional block. In general the loop
7008 -- should be the first statement in the statement sequence of the block,
7009 -- but the finalization machinery may have introduced extra object
7010 -- declarations.
7021 -- The expansion of attribute 'Loop_Entry produced a malformed block
7026 --------------------------
7027 -- Find_Overlaid_Entity --
7028 --------------------------
7030 procedure Find_Overlaid_Entity
7034 is
7037 begin
7038 -- We are looking for one of the two following forms:
7040 -- for X'Address use Y'Address
7042 -- or
7044 -- Const : constant Address := expr;
7045 -- ...
7046 -- for X'Address use Const;
7048 -- In the second case, the expr is either Y'Address, or recursively a
7049 -- constant that eventually references Y'Address.
7056 then
7059 -- This loop checks the form of the expression for Y'Address,
7060 -- using recursion to deal with intermediate constants.
7062 loop
7063 -- Check for Y'Address
7067 then
7071 -- Check for Const where Const is a constant entity
7075 then
7078 -- Anything else does not need checking
7080 else
7085 -- This loop checks the form of the prefix for an entity, using
7086 -- recursion to deal with intermediate components.
7088 loop
7089 -- Check for Y where Y is an entity
7095 -- Check for components
7097 elsif
7099 then
7103 -- Anything else does not need checking
7105 else
7112 -------------------------
7113 -- Find_Parameter_Type --
7114 -------------------------
7117 begin
7121 -- For an access parameter, obtain the type from the formal entity
7122 -- itself, because access to subprogram nodes do not carry a type.
7123 -- Shouldn't we always use the formal entity ???
7128 else
7133 -----------------------------------
7134 -- Find_Placement_In_State_Space --
7135 -----------------------------------
7137 procedure Find_Placement_In_State_Space
7141 is
7144 begin
7145 -- Assume that the item does not appear in the state space of a package
7150 -- Climb the scope stack and examine the enclosing context
7157 -- A package body is a cut off point for the traversal as the item
7158 -- cannot be visible to the outside from this point on. Note that
7159 -- this test must be done first as a body is also classified as a
7160 -- private part.
7166 -- The private part of a package is a cut off point for the
7167 -- traversal as the item cannot be visible to the outside from
7168 -- this point on.
7174 -- When the item appears in the visible state space of a package,
7175 -- continue to climb the scope stack as this may not be the final
7176 -- state space.
7178 else
7181 -- The visible state space of a child unit acts as the proper
7182 -- placement of an item.
7189 -- The item or its enclosing package appear in a construct that has
7190 -- no state space.
7192 else
7201 ------------------------
7202 -- Find_Specific_Type --
7203 ------------------------
7208 begin
7212 else
7220 then
7222 else
7227 -----------------------------
7228 -- Find_Static_Alternative --
7229 -----------------------------
7237 begin
7245 -- Others choice, always matches
7250 -- Range, check if value is in the range
7255 and then
7258 -- Choice is a subtype name. Note that we know it must
7259 -- be a static subtype, since otherwise it would have
7260 -- been diagnosed as illegal.
7264 then
7268 -- Choice is a subtype indication
7271 declare
7275 begin
7278 and then
7282 -- Choice is a simple expression
7284 else
7296 -- The above loop *must* terminate by finding a match, since
7297 -- we know the case statement is valid, and the value of the
7298 -- expression is known at compile time. When we fall out of
7299 -- the loop, Alt points to the alternative that we know will
7300 -- be selected at run time.
7305 ------------------
7306 -- First_Actual --
7307 ------------------
7312 begin
7321 else
7326 -------------
7327 -- Fix_Msg --
7328 -------------
7339 begin
7340 -- Copy all characters from the input message Msg to result Res with
7341 -- suitable replacements.
7347 -- Replace "subprogram" with a different word
7351 then
7360 else
7367 -- Replace "protected" with a different word
7371 and then Is_Task
7372 then
7377 -- Otherwise copy the character
7379 else
7389 -----------------------
7390 -- Gather_Components --
7391 -----------------------
7393 procedure Gather_Components
7399 is
7409 begin
7418 else
7424 -- Skip the tag of a tagged record, the interface tags, as well
7425 -- as all items that are not user components (anonymous types,
7426 -- rep clauses, Parent field, controller field).
7429 declare
7431 begin
7443 else
7448 -- Look for the discriminant that governs this variant part.
7449 -- The discriminant *must* be in the Governed_By List
7456 and then
7466 then
7467 -- If the type is a tagged type with inherited discriminants,
7468 -- use the stored constraint on the parent in order to find
7469 -- the values of discriminants that are otherwise hidden by an
7470 -- explicit constraint. Renamed discriminants are handled in
7471 -- the code above.
7473 -- If several parent discriminants are renamed by a single
7474 -- discriminant of the derived type, the call to obtain the
7475 -- Corresponding_Discriminant field only retrieves the last
7476 -- of them. We recover the constraint on the others from the
7477 -- Stored_Constraint as well.
7479 declare
7483 begin
7490 then
7491 -- D is renamed by Discrim, whose value is given in
7492 -- Assoc.
7496 else
7497 Assoc :=
7499 New_List
7527 -- If the variant part is governed by a discriminant of the type
7528 -- this is an error. If the variant part and the discriminant are
7529 -- inherited from an ancestor this is legal (AI05-120) unless the
7530 -- components are being gathered for an aggregate, in which case
7531 -- the caller must check Report_Errors.
7535 then
7536 Error_Msg_FE
7554 begin
7567 UI_Low <= UI_Discrim_Value
7568 and then
7579 Error_Msg_NE
7585 -- If we have found the corresponding choice, recursively add its
7586 -- components to the Into list. The nested components are part of
7587 -- the same record type.
7589 Gather_Components
7593 ------------------------
7594 -- Get_Actual_Subtype --
7595 ------------------------
7603 begin
7608 -- If what we have is an identifier that references a subprogram
7609 -- formal, or a variable or constant object, then we get the actual
7610 -- subtype from the referenced entity if one has been built.
7613 and then
7618 then
7621 -- Actual subtype of unchecked union is always itself. We never need
7622 -- the "real" actual subtype. If we did, we couldn't get it anyway
7623 -- because the discriminant is not available. The restrictions on
7624 -- Unchecked_Union are designed to make sure that this is OK.
7629 -- Here for the unconstrained case, we must find actual subtype
7630 -- No actual subtype is available, so we must build it on the fly.
7632 -- Checking the type, not the underlying type, for constrainedness
7633 -- seems to be necessary. Maybe all the tests should be on the type???
7641 then
7642 -- Nothing to do if in spec expression (why not???)
7649 -- If the type has no discriminants, there is no subtype to
7650 -- build, even if the underlying type is discriminated.
7654 -- Else build the actual subtype
7656 else
7660 -- If Build_Actual_Subtype generated a new declaration then use it
7664 -- The actual subtype is an Itype, so analyze the declaration,
7665 -- but do not attach it to the tree, to get the type defined.
7673 -- We need to freeze the actual subtype immediately. This is
7674 -- needed, because otherwise this Itype will not get frozen
7675 -- at all, and it is always safe to freeze on creation because
7676 -- any associated types must be frozen at this point.
7681 -- Otherwise we did not build a declaration, so return original
7683 else
7688 -- For all remaining cases, the actual subtype is the same as
7689 -- the nominal type.
7691 else
7696 -------------------------------------
7697 -- Get_Actual_Subtype_If_Available --
7698 -------------------------------------
7703 begin
7704 -- If what we have is an identifier that references a subprogram
7705 -- formal, or a variable or constant object, then we get the actual
7706 -- subtype from the referenced entity if one has been built.
7709 and then
7714 then
7717 -- Otherwise the Etype of N is returned unchanged
7719 else
7724 ------------------------
7725 -- Get_Body_From_Stub --
7726 ------------------------
7729 begin
7733 ---------------------
7734 -- Get_Cursor_Type --
7735 ---------------------
7737 function Get_Cursor_Type
7740 is
7746 begin
7747 -- If error already detected, return
7753 -- The cursor type for an Iterable aspect is the return type of a
7754 -- non-overloaded First primitive operation. Locate association for
7755 -- First.
7775 -- Locate function with desired name and profile in scope of type
7776 -- In the rare case where the type is an integer type, a base type
7777 -- is created for it, check that the base type of the first formal
7778 -- of First matches the base type of the domain.
7787 then
7789 Error_Msg_N
7792 else
7800 -- If not found, no way to resolve remaining primitives.
7803 Error_Msg_N
7811 begin
7815 -------------------------------
7816 -- Get_Default_External_Name --
7817 -------------------------------
7820 begin
7825 else
7829 return
7834 --------------------------
7835 -- Get_Enclosing_Object --
7836 --------------------------
7839 begin
7842 else
7844 when N_Indexed_Component |
7845 N_Slice |
7846 N_Selected_Component =>
7848 -- If not generating code, a dereference may be left implicit.
7849 -- In thoses cases, return Empty.
7853 else
7866 ---------------------------
7867 -- Get_Enum_Lit_From_Pos --
7868 ---------------------------
7870 function Get_Enum_Lit_From_Pos
7874 is
7878 begin
7879 -- In the case where the literal is of type Character, Wide_Character
7880 -- or Wide_Wide_Character or of a type derived from them, there needs
7881 -- to be some special handling since there is no explicit chain of
7882 -- literals to search. Instead, an N_Character_Literal node is created
7883 -- with the appropriate Char_Code and Chars fields.
7887 return
7892 -- For all other cases, we have a complete table of literals, and
7893 -- we simply iterate through the chain of literal until the one
7894 -- with the desired position value is found.
7896 else
7910 ------------------------
7911 -- Get_Generic_Entity --
7912 ------------------------
7916 begin
7919 else
7924 -------------------------------------
7925 -- Get_Incomplete_View_Of_Ancestor --
7926 -------------------------------------
7933 begin
7934 -- The incomplete view of an ancestor is only relevant for private
7935 -- derived types in child units.
7939 then
7942 else
7950 -- Traverse list of ancestor types until we find one declared in
7951 -- a parent or grandparent unit (two levels seem sufficient).
7956 then
7962 else
7967 -- If none found, there is no relevant ancestor type.
7973 ----------------------
7974 -- Get_Index_Bounds --
7975 ----------------------
7981 begin
7994 else
8007 else
8012 else
8013 -- N is an expression, indicating a range with one value
8020 ---------------------------------
8021 -- Get_Iterable_Type_Primitive --
8022 ---------------------------------
8024 function Get_Iterable_Type_Primitive
8027 is
8031 begin
8035 else
8049 ----------------------------------
8050 -- Get_Library_Unit_Name_string --
8051 ----------------------------------
8056 begin
8059 -- Remove seven last character (" (spec)" or " (body)")
8065 ------------------------
8066 -- Get_Name_Entity_Id --
8067 ------------------------
8070 begin
8074 ------------------------------
8075 -- Get_Name_From_CTC_Pragma --
8076 ------------------------------
8081 begin
8085 -----------------------
8086 -- Get_Parent_Entity --
8087 -----------------------
8090 begin
8093 then
8094 return Defining_Entity
8098 else
8103 -------------------
8104 -- Get_Pragma_Id --
8105 -------------------
8108 begin
8112 -----------------------
8113 -- Get_Reason_String --
8114 -----------------------
8117 begin
8125 -- If not of required form, error
8127 else
8128 Error_Msg_N
8130 Error_Msg_N
8136 --------------------------------
8137 -- Get_Reference_Discriminant --
8138 --------------------------------
8143 begin
8155 ---------------------------
8156 -- Get_Referenced_Object --
8157 ---------------------------
8162 begin
8166 loop
8173 ------------------------
8174 -- Get_Renamed_Entity --
8175 ------------------------
8180 begin
8189 -----------------------
8190 -- Get_Return_Object --
8191 -----------------------
8196 begin
8208 ---------------------------
8209 -- Get_Subprogram_Entity --
8210 ---------------------------
8216 begin
8223 else
8227 -- Strip the subprogram call
8229 loop
8231 N_Indexed_Component,
8232 N_Selected_Component)
8233 then
8237 N_Unchecked_Type_Conversion)
8238 then
8241 else
8246 -- Extract the entity of the subprogram call
8257 else
8261 -- The search did not find a construct that denotes a subprogram
8263 else
8268 -----------------------------
8269 -- Get_Task_Body_Procedure --
8270 -----------------------------
8273 begin
8274 -- Note: A task type may be the completion of a private type with
8275 -- discriminants. When performing elaboration checks on a task
8276 -- declaration, the current view of the type may be the private one,
8277 -- and the procedure that holds the body of the task is held in its
8278 -- underlying type.
8280 -- This is an odd function, why not have Task_Body_Procedure do
8281 -- the following digging???
8286 -------------------------
8287 -- Get_User_Defined_Eq --
8288 -------------------------
8294 begin
8303 then
8313 -----------------------
8314 -- Has_Access_Values --
8315 -----------------------
8320 begin
8321 -- Case of a private type which is not completed yet. This can only
8322 -- happen in the case of a generic format type appearing directly, or
8323 -- as a component of the type to which this function is being applied
8324 -- at the top level. Return False in this case, since we certainly do
8325 -- not know that the type contains access types.
8337 declare
8340 begin
8341 -- Loop to Check components
8346 -- Check for access component, tag field does not count, even
8347 -- though it is implemented internally using an access type.
8351 then
8361 else
8366 ------------------------------
8367 -- Has_Compatible_Alignment --
8368 ------------------------------
8370 function Has_Compatible_Alignment
8374 is
8375 function Has_Compatible_Alignment_Internal
8380 -- This is the internal recursive function that actually does the work.
8381 -- There is one additional parameter, which says what the result should
8382 -- be if no alignment information is found, and there is no definite
8383 -- indication of compatible alignments. At the outer level, this is set
8384 -- to Unknown, but for internal recursive calls in the case where types
8385 -- are known to be correct, it is set to Known_Compatible.
8387 ---------------------------------------
8388 -- Has_Compatible_Alignment_Internal --
8389 ---------------------------------------
8391 function Has_Compatible_Alignment_Internal
8396 is
8398 -- Holds the current status of the result. Note that once a value of
8399 -- Known_Incompatible is set, it is sticky and does not get changed
8400 -- to Unknown (the value in Result only gets worse as we go along,
8401 -- never better).
8404 -- Set to a factor of the offset from the base object when Expr is a
8405 -- selected or indexed component, based on Component_Bit_Offset and
8406 -- Component_Size respectively. A negative value is used to represent
8407 -- a value which is not known at compile time.
8410 -- Checks the prefix recursively in the case where the expression
8411 -- is an indexed or selected component.
8414 -- If R represents a worse outcome (unknown instead of known
8415 -- compatible, or known incompatible), then set Result to R.
8417 ------------------
8418 -- Check_Prefix --
8419 ------------------
8422 begin
8423 -- The subtlety here is that in doing a recursive call to check
8424 -- the prefix, we have to decide what to do in the case where we
8425 -- don't find any specific indication of an alignment problem.
8427 -- At the outer level, we normally set Unknown as the result in
8428 -- this case, since we can only set Known_Compatible if we really
8429 -- know that the alignment value is OK, but for the recursive
8430 -- call, in the case where the types match, and we have not
8431 -- specified a peculiar alignment for the object, we are only
8432 -- concerned about suspicious rep clauses, the default case does
8433 -- not affect us, since the compiler will, in the absence of such
8434 -- rep clauses, ensure that the alignment is correct.
8437 or else
8440 or else
8442 then
8443 Set_Result
8444 (Has_Compatible_Alignment_Internal
8447 -- In all other cases, we need a full check on the prefix
8449 else
8450 Set_Result
8451 (Has_Compatible_Alignment_Internal
8456 ----------------
8457 -- Set_Result --
8458 ----------------
8461 begin
8467 -- Start of processing for Has_Compatible_Alignment_Internal
8469 begin
8470 -- If Expr is a selected component, we must make sure there is no
8471 -- potentially troublesome component clause and that the record is
8472 -- not packed if the layout is not done.
8476 -- Packing generates unknown alignment if layout is not done
8482 -- Check prefix and component offset
8484 Check_Prefix;
8487 -- If Expr is an indexed component, we must make sure there is no
8488 -- potentially troublesome Component_Size clause and that the array
8489 -- is not bit-packed if the layout is not done.
8492 declare
8496 begin
8497 -- Packing generates unknown alignment if layout is not done
8503 -- Check prefix and component offset
8505 Check_Prefix;
8508 -- Small optimization: compute the full offset when possible
8516 then
8523 -- If we have a null offset, the result is entirely determined by
8524 -- the base object and has already been computed recursively.
8529 -- Case where we know the alignment of the object
8532 declare
8537 begin
8538 -- If alignment of Obj is 1, then we are always OK
8543 -- Alignment of Obj is greater than 1, so we need to check
8545 else
8546 -- If we have an offset, see if it is compatible
8553 -- See if Expr is an object with known alignment
8557 then
8560 -- Otherwise, we can use the alignment of the type of
8561 -- Expr given that we already checked for
8562 -- discombobulating rep clauses for the cases of indexed
8563 -- and selected components above.
8568 -- Otherwise the alignment is unknown
8570 else
8574 -- If we got an alignment, see if it is acceptable
8580 -- If Expr is not a piece of a larger object, see if size
8581 -- is given. If so, check that it is not too small for the
8582 -- required alignment.
8587 -- See if Expr is an object with known size
8591 then
8594 -- Otherwise, we check the object size of the Expr type
8600 -- If we got a size, see if it is a multiple of the Obj
8601 -- alignment, if not, then the alignment cannot be
8602 -- acceptable, since the size is always a multiple of the
8603 -- alignment.
8613 -- If we do not know required alignment, any non-zero offset is a
8614 -- potential problem (but certainly may be OK, so result is unknown).
8619 -- If we can't find the result by direct comparison of alignment
8620 -- values, then there is still one case that we can determine known
8621 -- result, and that is when we can determine that the types are the
8622 -- same, and no alignments are specified. Then we known that the
8623 -- alignments are compatible, even if we don't know the alignment
8624 -- value in the front end.
8628 -- Types are the same, but we have to check for possible size
8629 -- and alignments on the Expr object that may make the alignment
8630 -- different, even though the types are the same.
8634 -- First check alignment of the Expr object. Any alignment less
8635 -- than Maximum_Alignment is worrisome since this is the case
8636 -- where we do not know the alignment of Obj.
8640 Ttypes.Maximum_Alignment
8641 then
8644 -- Now check size of Expr object. Any size that is not an
8645 -- even multiple of Maximum_Alignment is also worrisome
8646 -- since it may cause the alignment of the object to be less
8647 -- than the alignment of the type.
8650 and then
8654 then
8657 -- Otherwise same type is decisive
8659 else
8664 -- Another case to deal with is when there is an explicit size or
8665 -- alignment clause when the types are not the same. If so, then the
8666 -- result is Unknown. We don't need to do this test if the Default is
8667 -- Unknown, since that result will be set in any case.
8671 or else
8673 then
8676 -- If no indication found, set default
8678 else
8682 -- Return worst result found
8687 -- Start of processing for Has_Compatible_Alignment
8689 begin
8690 -- If Obj has no specified alignment, then set alignment from the type
8691 -- alignment. Perhaps we should always do this, but for sure we should
8692 -- do it when there is an address clause since we can do more if the
8693 -- alignment is known.
8699 -- Now do the internal call that does all the work
8701 return
8705 ----------------------
8706 -- Has_Declarations --
8707 ----------------------
8710 begin
8712 N_Block_Statement,
8713 N_Compilation_Unit_Aux,
8714 N_Entry_Body,
8715 N_Package_Body,
8716 N_Protected_Body,
8717 N_Subprogram_Body,
8718 N_Task_Body,
8719 N_Package_Specification);
8722 ---------------------------------
8723 -- Has_Defaulted_Discriminants --
8724 ---------------------------------
8727 begin
8734 -------------------
8735 -- Has_Denormals --
8736 -------------------
8739 begin
8743 -------------------------------------------
8744 -- Has_Discriminant_Dependent_Constraint --
8745 -------------------------------------------
8747 function Has_Discriminant_Dependent_Constraint
8749 is
8755 begin
8756 -- Discriminants can't depend on discriminants
8761 else
8771 when N_Subtype_Indication |
8772 N_Range |
8773 N_Identifier
8774 =>
8797 --------------------------------------
8798 -- Has_Effectively_Volatile_Profile --
8799 --------------------------------------
8801 function Has_Effectively_Volatile_Profile
8803 is
8806 begin
8807 -- Inspect the formal parameters looking for an effectively volatile
8808 -- type.
8819 -- Inspect the return type of functions
8823 then
8830 --------------------------
8831 -- Has_Enabled_Property --
8832 --------------------------
8834 function Has_Enabled_Property
8837 is
8839 -- Determine whether a state denoted by Item_Id has the property enabled
8842 -- Determine whether a variable denoted by Item_Id has the property
8843 -- enabled.
8845 --------------------------------
8846 -- State_Has_Enabled_Property --
8847 --------------------------------
8857 begin
8858 -- The declaration of an external abstract state appears as an
8859 -- extension aggregate. If this is not the case, properties can never
8860 -- be set.
8866 -- When External appears as a simple option, it automatically enables
8867 -- all properties.
8873 then
8880 -- When External specifies particular properties, inspect those and
8881 -- find the desired one (if any).
8889 then
8892 -- Multiple properties appear as an aggregate
8896 -- Simple property form
8907 -- Property with expression form
8913 -- The property can be represented in two ways:
8914 -- others => <value>
8915 -- <property> => <value>
8920 then
8927 -- Single property
8929 else
8940 -----------------------------------
8941 -- Variable_Has_Enabled_Property --
8942 -----------------------------------
8946 -- Determine whether property pragma Prag (if present) denotes an
8947 -- enabled property.
8949 ----------------
8950 -- Is_Enabled --
8951 ----------------
8956 begin
8960 -- The pragma has an optional Boolean expression, the related
8961 -- property is enabled only when the expression evaluates to
8962 -- True.
8967 -- Otherwise the lack of expression enables the property by
8968 -- default.
8970 else
8974 -- The property was never set in the first place
8976 else
8981 -- Local variables
8992 -- Start of processing for Variable_Has_Enabled_Property
8994 begin
8995 -- A non-effectively volatile object can never possess external
8996 -- properties.
9001 -- External properties related to variables come in two flavors -
9002 -- explicit and implicit. The explicit case is characterized by the
9003 -- presence of a property pragma with an optional Boolean flag. The
9004 -- property is enabled when the flag evaluates to True or the flag is
9005 -- missing altogether.
9019 -- The implicit case lacks all property pragmas
9024 else
9029 -- Start of processing for Has_Enabled_Property
9031 begin
9032 -- Abstract states and variables have a flexible scheme of specifying
9033 -- external properties.
9041 -- Otherwise a property is enabled when the related item is effectively
9042 -- volatile.
9044 else
9049 -------------------------------------
9050 -- Has_Full_Default_Initialization --
9051 -------------------------------------
9058 begin
9059 -- A private type and its full view is fully default initialized when it
9060 -- is subject to pragma Default_Initial_Condition without an argument or
9061 -- with a non-null argument. Since any type may act as the full view of
9062 -- a private type, this check must be performed prior to the specialized
9063 -- tests below.
9067 then
9070 -- Pragma Default_Initial_Condition must be present if one of the
9071 -- related entity flags is set.
9076 -- A non-null argument guarantees full default initialization
9081 -- Otherwise the missing argument defaults the pragma to "True" which
9082 -- is considered a non-null argument (see above).
9084 else
9089 -- A scalar type is fully default initialized if it is subject to aspect
9090 -- Default_Value.
9095 -- An array type is fully default initialized if its element type is
9096 -- scalar and the array type carries aspect Default_Component_Value or
9097 -- the element type is fully default initialized.
9100 return
9104 -- A protected type, record type or type extension is fully default
9105 -- initialized if all its components either carry an initialization
9106 -- expression or have a type that is fully default initialized. The
9107 -- parent type of a type extension must be fully default initialized.
9111 -- Inspect all entities defined in the scope of the type, looking for
9112 -- uninitialized components.
9120 then
9127 -- Ensure that the parent type of a type extension is fully default
9128 -- initialized.
9132 then
9136 -- If we get here, then all components and parent portion are fully
9137 -- default initialized.
9141 -- A task type is fully default initialized by default
9146 -- Otherwise the type is not fully default initialized
9148 else
9153 --------------------
9154 -- Has_Infinities --
9155 --------------------
9158 begin
9159 return
9165 --------------------
9166 -- Has_Interfaces --
9167 --------------------
9169 function Has_Interfaces
9172 is
9175 begin
9176 -- Handle concurrent types
9185 then
9189 -- Handle private types
9195 -- Handle concurrent record types
9199 then
9203 loop
9205 or else
9209 then
9215 -- Handle private types
9220 -- Protect frontend against wrong sources with cyclic derivations
9224 -- Climb to the ancestor type handling private types
9228 else
9236 ---------------------------------
9237 -- Has_No_Obvious_Side_Effects --
9238 ---------------------------------
9241 begin
9242 -- For now, just handle literals, constants, and non-volatile
9243 -- variables and expressions combining these with operators or
9244 -- short circuit forms.
9257 and then
9262 then
9268 E_Constant,
9269 E_Enumeration_Literal,
9270 E_In_Parameter,
9271 E_Out_Parameter,
9272 E_In_Out_Parameter)
9275 else
9280 -----------------------------
9281 -- Has_Non_Null_Refinement --
9282 -----------------------------
9285 begin
9288 -- For a refinement to be non-null, the first constituent must be
9289 -- anything other than null.
9292 return
9299 ------------------------
9300 -- Has_Null_Exclusion --
9301 ------------------------
9304 begin
9306 when N_Access_Definition |
9307 N_Access_Function_Definition |
9308 N_Access_Procedure_Definition |
9309 N_Access_To_Object_Definition |
9310 N_Allocator |
9311 N_Derived_Type_Definition |
9312 N_Function_Specification |
9313 N_Subtype_Declaration =>
9316 when N_Component_Definition |
9317 N_Formal_Object_Declaration |
9318 N_Object_Renaming_Declaration =>
9328 else
9335 else
9342 else
9352 ------------------------
9353 -- Has_Null_Extension --
9354 ------------------------
9361 begin
9364 then
9370 else
9373 -- The null component list is rewritten during analysis to
9374 -- include the parent component. Any other component indicates
9375 -- that the extension was not originally null.
9380 else
9384 else
9389 -------------------------
9390 -- Has_Null_Refinement --
9391 -------------------------
9394 begin
9397 -- For a refinement to be null, the state's sole constituent must be a
9398 -- null.
9401 return
9408 -------------------------------
9409 -- Has_Overriding_Initialize --
9410 -------------------------------
9416 begin
9424 declare
9427 begin
9436 then
9445 -- Here if type itself does not have a non-null Initialize operation:
9446 -- check immediate ancestor.
9450 then
9458 --------------------------------------
9459 -- Has_Preelaborable_Initialization --
9460 --------------------------------------
9466 -- Check component/discriminant chain, sets Has_PE False if a component
9467 -- or discriminant does not meet the preelaborable initialization rules.
9469 ----------------------
9470 -- Check_Components --
9471 ----------------------
9478 -- Returns True if and only if the expression denoted by N does not
9479 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
9481 ---------------------------------
9482 -- Is_Preelaborable_Expression --
9483 ---------------------------------
9492 begin
9499 -- Attributes are allowed in general, even if their prefix is a
9500 -- formal type. (It seems that certain attributes known not to be
9501 -- static might not be allowed, but there are no rules to prevent
9502 -- them.)
9507 -- The name of a discriminant evaluated within its parent type is
9508 -- defined to be preelaborable (10.2.1(8)). Note that we test for
9509 -- names that denote discriminals as well as discriminants to
9510 -- catch references occurring within init procs.
9513 and then
9517 then
9523 -- For aggregates we have to check that each of the associations
9524 -- is preelaborable.
9533 -- Check the ancestor part of extension aggregates, which must
9534 -- be either the name of a type that has preelaborable init or
9535 -- an expression that is preelaborable.
9538 declare
9541 begin
9544 then
9545 if not Has_Preelaborable_Initialization
9547 then
9557 -- Check positional associations
9568 -- Check named associations
9587 else
9594 -- If the association has a <> at this point, then we have
9595 -- to check whether the component's type has preelaborable
9596 -- initialization. Note that this only occurs when the
9597 -- association's corresponding component does not have a
9598 -- default expression, the latter case having already been
9599 -- expanded as an expression for the association.
9606 -- In the expression case we check whether the expression
9607 -- is preelaborable.
9609 elsif
9611 then
9618 -- If we get here then aggregate as a whole is preelaborable
9622 -- All other cases are not preelaborable
9624 else
9629 -- Start of processing for Check_Components
9631 begin
9632 -- Loop through entities of record or protected type
9637 -- We are interested only in components and discriminants
9644 -- Get default expression if any. If there is no declaration
9645 -- node, it means we have an internal entity. The parent and
9646 -- tag fields are examples of such entities. For such cases,
9647 -- we just test the type of the entity.
9655 -- Note: for a renamed discriminant, the Declaration_Node
9656 -- may point to the one from the ancestor, and have a
9657 -- different expression, so use the proper attribute to
9658 -- retrieve the expression from the derived constraint.
9666 -- A component has PI if it has no default expression and the
9667 -- component type has PI.
9675 -- Require the default expression to be preelaborable
9687 -- Start of processing for Has_Preelaborable_Initialization
9689 begin
9690 -- Immediate return if already marked as known preelaborable init. This
9691 -- covers types for which this function has already been called once
9692 -- and returned True (in which case the result is cached), and also
9693 -- types to which a pragma Preelaborable_Initialization applies.
9699 -- If the type is a subtype representing a generic actual type, then
9700 -- test whether its base type has preelaborable initialization since
9701 -- the subtype representing the actual does not inherit this attribute
9702 -- from the actual or formal. (but maybe it should???)
9708 -- All elementary types have preelaborable initialization
9713 -- Array types have PI if the component type has PI
9718 -- A derived type has preelaborable initialization if its parent type
9719 -- has preelaborable initialization and (in the case of a derived record
9720 -- extension) if the non-inherited components all have preelaborable
9721 -- initialization. However, a user-defined controlled type with an
9722 -- overriding Initialize procedure does not have preelaborable
9723 -- initialization.
9727 -- If the derived type is a private extension then it doesn't have
9728 -- preelaborable initialization.
9734 -- First check whether ancestor type has preelaborable initialization
9738 -- If OK, check extension components (if any)
9744 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
9745 -- with a user defined Initialize procedure does not have PI. If
9746 -- the type is untagged, the control primitives come from a component
9747 -- that has already been checked.
9749 if Has_PE
9753 then
9757 -- Private types not derived from a type having preelaborable init and
9758 -- that are not marked with pragma Preelaborable_Initialization do not
9759 -- have preelaborable initialization.
9764 -- Record type has PI if it is non private and all components have PI
9770 -- Protected types must not have entries, and components must meet
9771 -- same set of rules as for record components.
9776 else
9782 -- Type System.Address always has preelaborable initialization
9787 -- In all other cases, type does not have preelaborable initialization
9789 else
9793 -- If type has preelaborable initialization, cache result
9802 ---------------------------
9803 -- Has_Private_Component --
9804 ---------------------------
9810 begin
9813 then
9822 declare
9824 begin
9828 and then
9830 else
9833 else
9855 then
9858 else
9863 ----------------------
9864 -- Has_Signed_Zeros --
9865 ----------------------
9868 begin
9872 ------------------------------
9873 -- Has_Significant_Contract --
9874 ------------------------------
9879 begin
9880 -- _Finalizer procedure
9885 -- _Postconditions procedure
9890 -- Predicate function
9894 then
9897 -- TSS subprogram
9902 else
9907 -----------------------------
9908 -- Has_Static_Array_Bounds --
9909 -----------------------------
9918 begin
9919 -- Unconstrained types do not have static bounds
9925 -- First treat string literals specially, as the lower bound and length
9926 -- of string literals are not stored like those of arrays.
9928 -- A string literal always has static bounds
9934 -- Treat all dimensions in turn
9939 -- In case of an illegal index which is not a discrete type, return
9940 -- that the type is not static.
9944 then
9955 and then
9957 then
9959 else
9966 -- If we fall through the loop, all indexes matched
9971 ----------------
9972 -- Has_Stream --
9973 ----------------
9978 begin
9993 else
10003 else
10008 ----------------
10009 -- Has_Suffix --
10010 ----------------
10013 begin
10018 ----------------
10019 -- Add_Suffix --
10020 ----------------
10023 begin
10029 -------------------
10030 -- Remove_Suffix --
10031 -------------------
10034 begin
10041 --------------------------
10042 -- Has_Tagged_Component --
10043 --------------------------
10048 begin
10070 else
10075 -----------------------------
10076 -- Has_Undefined_Reference --
10077 -----------------------------
10081 -- Flag set when expression Expr contains at least one undefined
10082 -- reference.
10085 -- Determine whether N denotes a reference and if it does, whether it is
10086 -- undefined.
10088 ----------------------------
10089 -- Is_Undefined_Reference --
10090 ----------------------------
10093 begin
10097 then
10108 -- Start of processing for Has_Undefined_Reference
10110 begin
10116 ----------------------------
10117 -- Has_Volatile_Component --
10118 ----------------------------
10123 begin
10144 -------------------------
10145 -- Implementation_Kind --
10146 -------------------------
10151 begin
10157 --------------------------
10158 -- Implements_Interface --
10159 --------------------------
10161 function Implements_Interface
10165 is
10171 begin
10189 and then Exclude_Parents
10190 then
10203 ------------------------------------
10204 -- In_Assertion_Expression_Pragma --
10205 ------------------------------------
10211 begin
10212 -- Climb the parent chain looking for an enclosing pragma
10220 -- Precondition-like pragmas are expanded into if statements, check
10221 -- the original node instead.
10227 -- The expansion of attribute 'Old generates a constant to capture
10228 -- the result of the prefix. If the parent traversal reaches
10229 -- one of these constants, then the node technically came from a
10230 -- postcondition-like pragma. Note that the Ekind is not tested here
10231 -- because N may be the expression of an object declaration which is
10232 -- currently being analyzed. Such objects carry Ekind of E_Void.
10237 then
10240 -- Prevent the search from going too far
10249 return
10254 -----------------
10255 -- In_Instance --
10256 -----------------
10262 begin
10267 then
10268 -- A child instance is always compiled in the context of a parent
10269 -- instance. Nevertheless, the actuals are not analyzed in an
10270 -- instance context. We detect this case by examining the current
10271 -- compilation unit, which must be a child instance, and checking
10272 -- that it is not currently on the scope stack.
10276 N_Package_Instantiation
10278 then
10280 else
10291 ----------------------
10292 -- In_Instance_Body --
10293 ----------------------
10298 begin
10303 then
10309 then
10319 -----------------------------
10320 -- In_Instance_Not_Visible --
10321 -----------------------------
10326 begin
10331 then
10337 then
10347 ------------------------------
10348 -- In_Instance_Visible_Part --
10349 ------------------------------
10354 begin
10361 then
10371 ---------------------
10372 -- In_Package_Body --
10373 ---------------------
10378 begin
10383 else
10391 --------------------------------
10392 -- In_Parameter_Specification --
10393 --------------------------------
10398 begin
10411 --------------------------
10412 -- In_Pragma_Expression --
10413 --------------------------
10417 begin
10419 loop
10424 else
10430 -------------------------------------
10431 -- In_Reverse_Storage_Order_Object --
10432 -------------------------------------
10438 begin
10439 -- Climb up indexed components
10442 loop
10466 --------------------------------------
10467 -- In_Subprogram_Or_Concurrent_Unit --
10468 --------------------------------------
10474 begin
10475 -- Use scope chain to check successively outer scopes
10478 loop
10484 then
10495 ---------------------
10496 -- In_Visible_Part --
10497 ---------------------
10500 begin
10507 --------------------------------
10508 -- Incomplete_Or_Partial_View --
10509 --------------------------------
10512 function Inspect_Decls
10515 -- Check whether a declarative region contains the incomplete or partial
10516 -- view of Id.
10518 -------------------
10519 -- Inspect_Decls --
10520 -------------------
10522 function Inspect_Decls
10525 is
10529 begin
10539 else
10541 N_Private_Type_Declaration)
10542 then
10550 then
10560 -- Local variables
10564 -- Start of processing for Incomplete_Or_Partial_View
10566 begin
10567 -- Deferred constant or incomplete type case
10575 then
10579 -- Private or Taft amendment type case
10581 declare
10585 begin
10591 -- It is knows that Typ has a private view, look for it in the
10592 -- visible declarations of the enclosing scope. A special case
10593 -- of this is when the two views have been exchanged - the full
10594 -- appears earlier than the private.
10599 -- Exchanged view case, look in the private declarations
10607 -- Otherwise if this is the package body, then Typ is a potential
10608 -- Taft amendment type. The incomplete view should be located in
10609 -- the private declarations of the enclosing scope.
10617 -- The type has no incomplete or private view
10622 -----------------------------------------
10623 -- Inherit_Default_Init_Cond_Procedure --
10624 -----------------------------------------
10629 begin
10630 -- A derived type inherits the default initial condition procedure of
10631 -- its parent type.
10634 Set_Default_Init_Cond_Procedure
10639 ----------------------------
10640 -- Inherit_Rep_Item_Chain --
10641 ----------------------------
10648 begin
10649 -- Reach the end of the destination type's chain (if any) and capture
10650 -- the last item.
10655 -- Do not inherit a chain that has been inherited already
10667 -- Additional check when both parent and current type have rep.
10668 -- items, to prevent circularities when the derivation completes
10669 -- a private declaration and inherits from both views of the parent.
10670 -- There may be a remaining problem with the proper ordering of
10671 -- attribute specifications and aspects on the chains of the four
10672 -- entities involved. ???
10684 -- When the destination type has a rep item chain, the chain of the
10685 -- source type is appended to it.
10690 -- Otherwise the destination type directly inherits the rep item chain
10691 -- of the source type (if any).
10693 else
10698 ---------------------------------
10699 -- Insert_Explicit_Dereference --
10700 ---------------------------------
10710 begin
10721 -- The dereference is also overloaded, and its interpretations are
10722 -- the designated types of the interpretations of the original node.
10737 End_Interp_List;
10739 else
10740 -- Prefix is unambiguous: mark the original prefix (which might
10741 -- Come_From_Source) as a reference, since the new (relocated) one
10742 -- won't be taken into account.
10748 -- For a retrieval of a subcomponent of some composite object,
10749 -- retrieve the ultimate entity if there is one.
10752 N_Indexed_Component)
10753 then
10757 N_Indexed_Component)
10758 loop
10767 -- Place the reference on the entity node
10775 ------------------------------------------
10776 -- Inspect_Deferred_Constant_Completion --
10777 ------------------------------------------
10782 begin
10786 -- Deferred constant signature
10792 -- No need to check internally generated constants
10796 -- The constant is not completed. A full object declaration or a
10797 -- pragma Import complete a deferred constant.
10800 then
10801 Error_Msg_N
10810 -----------------------------
10811 -- Install_Generic_Formals --
10812 -----------------------------
10817 begin
10827 -----------------------------
10828 -- Is_Actual_Out_Parameter --
10829 -----------------------------
10834 begin
10839 -------------------------
10840 -- Is_Actual_Parameter --
10841 -------------------------
10846 begin
10853 and then
10861 --------------------------------
10862 -- Is_Actual_Tagged_Parameter --
10863 --------------------------------
10868 begin
10873 ---------------------
10874 -- Is_Aliased_View --
10875 ---------------------
10880 begin
10884 return
10886 and then
10893 E_Generic_In_Parameter))
10898 -- Current instance of type, either directly or as rewritten
10899 -- reference to the current object.
10910 -- Ada 2012 AI05-0053: the return object of an extended return
10911 -- statement is aliased if its type is immutably limited.
10921 or else
10923 and then Has_Aliased_Components
10933 else
10938 -------------------------
10939 -- Is_Ancestor_Package --
10940 -------------------------
10942 function Is_Ancestor_Package
10945 is
10948 begin
10961 ----------------------
10962 -- Is_Atomic_Object --
10963 ----------------------
10968 -- Determines if given object has atomic components
10971 -- If prefix is an implicit dereference, examine designated type
10973 ----------------------
10974 -- Is_Atomic_Prefix --
10975 ----------------------
10978 begin
10980 return
10982 else
10987 ----------------------------------
10988 -- Object_Has_Atomic_Components --
10989 ----------------------------------
10992 begin
10995 then
11001 then
11006 then
11011 then
11014 else
11019 -- Start of processing for Is_Atomic_Object
11021 begin
11022 -- Predicate is not relevant to subprograms
11029 then
11034 then
11039 then
11042 else
11047 -----------------------------
11048 -- Is_Atomic_Or_VFA_Object --
11049 -----------------------------
11052 begin
11057 or else
11061 -------------------------
11062 -- Is_Attribute_Result --
11063 -------------------------
11066 begin
11071 -------------------------
11072 -- Is_Attribute_Update --
11073 -------------------------
11076 begin
11081 ------------------------------------
11082 -- Is_Body_Or_Package_Declaration --
11083 ------------------------------------
11086 begin
11088 N_Package_Body,
11089 N_Package_Declaration,
11090 N_Protected_Body,
11091 N_Subprogram_Body,
11092 N_Task_Body);
11095 -----------------------
11096 -- Is_Bounded_String --
11097 -----------------------
11102 begin
11103 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
11104 -- Super_String, or one of the [Wide_]Wide_ versions. This will
11105 -- be True for all the Bounded_String types in instances of the
11106 -- Generic_Bounded_Length generics, and for types derived from those.
11114 -------------------------
11115 -- Is_Child_Or_Sibling --
11116 -------------------------
11118 function Is_Child_Or_Sibling
11121 is
11123 -- Given an arbitrary package, return the number of "climbs" necessary
11124 -- to reach scope Standard_Standard.
11126 procedure Equalize_Depths
11130 -- Given an arbitrary package, its depth and a target depth to reach,
11131 -- climb the scope chain until the said depth is reached. The pointer
11132 -- to the package and its depth a modified during the climb.
11134 ----------------------------
11135 -- Distance_From_Standard --
11136 ----------------------------
11142 begin
11153 ---------------------
11154 -- Equalize_Depths --
11155 ---------------------
11157 procedure Equalize_Depths
11161 is
11162 begin
11163 -- The package must be at a greater or equal depth
11169 -- Climb the scope chain until the desired depth is reached
11177 -- Local variables
11186 -- Start of processing for Is_Child_Or_Sibling
11188 begin
11189 pragma Assert
11192 -- Both packages denote the same entity, therefore they cannot be
11193 -- children or siblings.
11198 -- One of the packages is at a deeper level than the other. Note that
11199 -- both may still come from differen hierarchies.
11201 -- (root) P_2
11202 -- / \ :
11203 -- X P_2 or X
11204 -- : :
11205 -- P_1 P_1
11208 Equalize_Depths
11214 -- (root) P_1
11215 -- / \ :
11216 -- P_1 X or X
11217 -- : :
11218 -- P_2 P_2
11221 Equalize_Depths
11228 -- At this stage the package pointers have been elevated to the same
11229 -- depth. If the related entities are the same, then one package is a
11230 -- potential child of the other:
11232 -- P_1
11233 -- :
11234 -- X became P_1 P_2 or vica versa
11235 -- :
11236 -- P_2
11246 -- The packages may come from the same package chain or from entirely
11247 -- different hierarcies. To determine this, climb the scope stack until
11248 -- a common root is found.
11250 -- (root) (root 1) (root 2)
11251 -- / \ | |
11252 -- P_1 P_2 P_1 P_2
11254 else
11257 -- The two packages may be siblings
11271 -----------------------------
11272 -- Is_Concurrent_Interface --
11273 -----------------------------
11276 begin
11278 and then
11284 -----------------------
11285 -- Is_Constant_Bound --
11286 -----------------------
11289 begin
11302 else
11307 ---------------------------
11308 -- Is_Container_Element --
11309 ---------------------------
11316 -- Call to an indexing aspect
11319 -- The type of the container being accessed
11322 -- Its element type
11326 -- Indicates that constant indexing is used, and the element is thus
11327 -- a constant.
11330 -- The reference type returned by the indexing operation
11332 begin
11333 -- If C is a container, in a context that imposes the element type of
11334 -- that container, the indexing notation C (X) is rewritten as:
11336 -- Indexing (C, X).Discr.all
11338 -- where Indexing is one of the indexing aspects of the container.
11339 -- If the context does not require a reference, the construct can be
11340 -- rewritten as
11342 -- Element (C, X)
11344 -- First, verify that the construct has the proper form
11355 else
11363 then
11367 -- Retrieve type of container object, and its iterator aspects
11375 -- Container should have at least one indexing operation
11381 -- This may be a variable indexing operation
11387 then
11391 else
11401 -- Check that the expression is not the target of an assignment, in
11402 -- which case the rewriting is not possible.
11405 declare
11408 begin
11411 loop
11414 then
11417 -- A renaming produces a reference, and the transformation
11418 -- does not apply.
11423 elsif Nkind_In
11425 N_Procedure_Call_Statement,
11426 N_Entry_Call_Statement)
11427 then
11428 -- Check that the element is not part of an actual for an
11429 -- in-out parameter.
11431 declare
11435 begin
11448 -- E_In_Parameter in a call: element is not modified.
11458 -- The expression has the proper form and the context requires the
11459 -- element type. Retrieve the Element function of the container and
11460 -- rewrite the construct as a call to it.
11462 declare
11465 begin
11475 else
11486 ----------------------------
11487 -- Is_Contract_Annotation --
11488 ----------------------------
11491 begin
11493 or else
11497 --------------------------------------
11498 -- Is_Controlling_Limited_Procedure --
11499 --------------------------------------
11501 function Is_Controlling_Limited_Procedure
11503 is
11506 begin
11509 then
11513 -- In this case where an Itype was created, the procedure call has been
11514 -- rewritten.
11518 and then
11519 Present (Parameter_Associations
11521 then
11522 Param_Typ :=
11528 return
11536 -----------------------------
11537 -- Is_CPP_Constructor_Call --
11538 -----------------------------
11541 begin
11548 -------------------------
11549 -- Is_Current_Instance --
11550 -------------------------
11556 begin
11557 -- Simplest case: entity is a concurrent type and we are currently
11558 -- inside the body. This will eventually be expanded into a
11559 -- call to Self (for tasks) or _object (for protected objects).
11564 else
11565 -- Check whether the context is a (sub)type declaration for the
11566 -- type entity.
11571 N_Private_Type_Declaration,
11572 N_Subtype_Declaration)
11575 then
11578 -- A subtype name may appear in an aspect specification for a
11579 -- Predicate_Failure aspect, for which we do not construct a
11580 -- wrapper procedure. The subtype will be replaced by the
11581 -- expression being tested when the corresponding predicate
11582 -- check is expanded.
11586 then
11590 and then
11592 then
11600 -- In any other context this is not a current occurrence
11605 --------------------
11606 -- Is_Declaration --
11607 --------------------
11610 begin
11612 when N_Abstract_Subprogram_Declaration |
11613 N_Exception_Declaration |
11614 N_Exception_Renaming_Declaration |
11615 N_Full_Type_Declaration |
11616 N_Generic_Function_Renaming_Declaration |
11617 N_Generic_Package_Declaration |
11618 N_Generic_Package_Renaming_Declaration |
11619 N_Generic_Procedure_Renaming_Declaration |
11620 N_Generic_Subprogram_Declaration |
11621 N_Number_Declaration |
11622 N_Object_Declaration |
11623 N_Object_Renaming_Declaration |
11624 N_Package_Declaration |
11625 N_Package_Renaming_Declaration |
11626 N_Private_Extension_Declaration |
11627 N_Private_Type_Declaration |
11628 N_Subprogram_Declaration |
11629 N_Subprogram_Renaming_Declaration |
11630 N_Subtype_Declaration =>
11638 --------------------------------
11639 -- Is_Declared_Within_Variant --
11640 --------------------------------
11645 begin
11649 ----------------------------------------------
11650 -- Is_Dependent_Component_Of_Mutable_Object --
11651 ----------------------------------------------
11653 function Is_Dependent_Component_Of_Mutable_Object
11655 is
11662 -- Dereference node, in something like X.all.Y(2)
11664 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
11666 begin
11667 -- Find the dereference node if any
11670 N_Selected_Component,
11671 N_Slice)
11672 loop
11676 -- Ada 2005: If we have a component or slice of a dereference,
11677 -- something like X.all.Y (2), and the type of X is access-to-constant,
11678 -- Is_Variable will return False, because it is indeed a constant
11679 -- view. But it might be a view of a variable object, so we want the
11680 -- following condition to be True in that case.
11685 then
11699 -- A discriminant check on a selected component may be expanded
11700 -- into a dereference when removing side-effects. Recover the
11701 -- original node and its type, which may be unconstrained.
11705 then
11709 else
11710 -- Check for prefix being an aliased component???
11716 -- A heap object is constrained by its initial value
11718 -- Ada 2005 (AI-363): Always assume the object could be mutable in
11719 -- the dereferenced case, since the access value might denote an
11720 -- unconstrained aliased object, whereas in Ada 95 the designated
11721 -- object is guaranteed to be constrained. A worst-case assumption
11722 -- has to apply in Ada 2005 because we can't tell at compile
11723 -- time whether the object is "constrained by its initial value"
11724 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
11725 -- rules (these rules are acknowledged to need fixing).
11730 then
11737 -- If the access type is pool-specific, and there is no
11738 -- constrained partial view of the designated type, then the
11739 -- designated object is known to be constrained.
11742 and then not Object_Type_Has_Constrained_Partial_View
11745 then
11748 -- Otherwise (general access type, or there is a constrained
11749 -- partial view of the designated type), we need to check
11750 -- based on the designated type.
11752 else
11758 Comp :=
11761 -- As per AI-0017, the renaming is illegal in a generic body, even
11762 -- if the subtype is indefinite.
11764 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
11768 or else
11776 then
11779 -- If the prefix is of an access type at this point, then we want
11780 -- to return False, rather than calling this function recursively
11781 -- on the access object (which itself might be a discriminant-
11782 -- dependent component of some other object, but that isn't
11783 -- relevant to checking the object passed to us). This avoids
11784 -- issuing wrong errors when compiling with -gnatc, where there
11785 -- can be implicit dereferences that have not been expanded.
11790 else
11791 return
11797 then
11800 -- A type conversion that Is_Variable is a view conversion:
11801 -- go back to the denoted object.
11804 return
11812 ---------------------
11813 -- Is_Dereferenced --
11814 ---------------------
11818 begin
11820 N_Explicit_Dereference,
11821 N_Indexed_Component,
11822 N_Slice)
11826 ----------------------
11827 -- Is_Descendant_Of --
11828 ----------------------
11834 begin
11840 -- Immediate return if the types match
11845 -- Comment needed here ???
11850 -- All other cases
11852 else
11853 loop
11856 -- Done if we found the type we are looking for
11861 -- Done if no more derivations to check
11865 then
11868 -- Following test catches error cases resulting from prev errors
11885 ----------------------------------------
11886 -- Is_Descendant_Of_Suspension_Object --
11887 ----------------------------------------
11889 function Is_Descendant_Of_Suspension_Object
11891 is
11895 begin
11896 -- Climb the type derivation chain checking each parent type against
11897 -- Suspension_Object.
11903 -- The current type is a match
11908 -- Stop the traversal once the root of the derivation chain has been
11909 -- reached. In that case the current type is its own base type.
11921 ---------------------------------------------
11922 -- Is_Double_Precision_Floating_Point_Type --
11923 ---------------------------------------------
11925 function Is_Double_Precision_Floating_Point_Type
11927 begin
11935 -----------------------------
11936 -- Is_Effectively_Volatile --
11937 -----------------------------
11940 begin
11943 -- An arbitrary type is effectively volatile when it is subject to
11944 -- pragma Atomic or Volatile.
11949 -- An array type is effectively volatile when it is subject to pragma
11950 -- Atomic_Components or Volatile_Components or its compolent type is
11951 -- effectively volatile.
11954 return
11956 or else
11959 -- A protected type is always volatile
11964 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
11965 -- automatically volatile.
11970 -- Otherwise the type is not effectively volatile
11972 else
11976 -- Otherwise Id denotes an object
11978 else
11979 return
11986 ------------------------------------
11987 -- Is_Effectively_Volatile_Object --
11988 ------------------------------------
11991 begin
12002 return
12004 or else
12007 else
12012 -------------------
12013 -- Is_Entry_Body --
12014 -------------------
12017 begin
12018 return
12023 --------------------------
12024 -- Is_Entry_Declaration --
12025 --------------------------
12028 begin
12029 return
12034 ----------------------------
12035 -- Is_Expression_Function --
12036 ----------------------------
12039 begin
12041 return
12043 N_Expression_Function;
12044 else
12049 ------------------------------------------
12050 -- Is_Expression_Function_Or_Completion --
12051 ------------------------------------------
12053 function Is_Expression_Function_Or_Completion
12055 is
12058 begin
12062 -- The function declaration is either an expression function or is
12063 -- completed by an expression function body.
12065 return
12069 and then Is_Expression_Function
12075 else
12080 -----------------------
12081 -- Is_EVF_Expression --
12082 -----------------------
12090 begin
12091 -- Detect a reference to a formal parameter of a specific tagged type
12092 -- whose related subprogram is subject to pragma Expresions_Visible with
12093 -- value "False".
12098 return
12102 Extensions_Visible_False;
12104 -- A case expression is an EVF expression when it contains at least one
12105 -- EVF dependent_expression. Note that a case expression may have been
12106 -- expanded, hence the use of Original_Node.
12118 -- An if expression is an EVF expression when it contains at least one
12119 -- EVF dependent_expression. Note that an if expression may have been
12120 -- expanded, hence the use of Original_Node.
12132 -- A qualified expression or a type conversion is an EVF expression when
12133 -- its operand is an EVF expression.
12136 N_Unchecked_Type_Conversion,
12137 N_Type_Conversion)
12138 then
12141 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
12142 -- their prefix denotes an EVF expression.
12146 Name_Old,
12147 Name_Update)
12148 then
12155 --------------
12156 -- Is_False --
12157 --------------
12160 begin
12164 ---------------------------
12165 -- Is_Fixed_Model_Number --
12166 ---------------------------
12172 begin
12179 -------------------------------
12180 -- Is_Fully_Initialized_Type --
12181 -------------------------------
12184 begin
12185 -- Scalar types
12189 -- A scalar type with an aspect Default_Value is fully initialized
12191 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
12192 -- of a scalar type, but we don't take that into account here, since
12193 -- we don't want these to affect warnings.
12203 then
12207 -- An interesting case, if we have a constrained type one of whose
12208 -- bounds is known to be null, then there are no elements to be
12209 -- initialized, so all the elements are initialized.
12212 declare
12217 begin
12223 -- If index is a range, use directly
12229 else
12238 else
12245 and then
12247 then
12258 -- If no null indexes, then type is not fully initialized
12262 -- Record types
12266 and then
12269 then
12273 -- We consider bounded string types to be fully initialized, because
12274 -- otherwise we get false alarms when the Data component is not
12275 -- default-initialized.
12281 -- Controlled records are considered to be fully initialized if
12282 -- there is a user defined Initialize routine. This may not be
12283 -- entirely correct, but as the spec notes, we are guessing here
12284 -- what is best from the point of view of issuing warnings.
12287 declare
12290 begin
12292 declare
12294 (Find_Optional_Prim_Op
12297 begin
12300 and then not
12301 Is_Predefined_File_Name
12303 then
12307 and then
12308 Is_Fully_Initialized_Type
12310 then
12318 -- Otherwise see if all record components are initialized
12320 declare
12323 begin
12331 -- Special VM case for tag components, which need to be
12332 -- defined in this case, but are never initialized as VMs
12333 -- are using other dispatching mechanisms. Ignore this
12334 -- uninitialized case. Note that this applies both to the
12335 -- uTag entry and the main vtable pointer (CPP_Class case).
12338 then
12346 -- No uninitialized components, so type is fully initialized.
12347 -- Note that this catches the case of no components as well.
12355 declare
12358 begin
12361 else
12366 else
12371 ----------------------------------
12372 -- Is_Fully_Initialized_Variant --
12373 ----------------------------------
12388 begin
12396 then
12406 then
12411 else
12414 else
12421 Gather_Components
12428 -- Check that each component present is fully initialized
12438 then
12448 declare
12451 begin
12454 else
12459 else
12464 ------------------------------------
12465 -- Is_Generic_Declaration_Or_Body --
12466 ------------------------------------
12471 begin
12472 -- Package/subprogram body
12476 then
12479 -- Package/subprogram body stub
12483 then
12484 Spec_Decl :=
12487 -- All other cases
12489 else
12493 -- Rather than inspecting the defining entity of the spec declaration,
12494 -- look at its Nkind. This takes care of the case where the analysis of
12495 -- a generic body modifies the Ekind of its spec to allow for recursive
12496 -- calls.
12498 return
12500 N_Generic_Subprogram_Declaration);
12503 ----------------------------
12504 -- Is_Inherited_Operation --
12505 ----------------------------
12510 begin
12518 -------------------------------------
12519 -- Is_Inherited_Operation_For_Type --
12520 -------------------------------------
12522 function Is_Inherited_Operation_For_Type
12525 is
12526 begin
12527 -- Check that the operation has been created by the type declaration
12533 -----------------
12534 -- Is_Iterator --
12535 -----------------
12539 -- Determine whether type Iter_Typ is a predefined forward or reversible
12540 -- iterator.
12542 ----------------------
12543 -- Denotes_Iterator --
12544 ----------------------
12547 begin
12548 return
12550 Name_Reversible_Iterator)
12551 and then Is_Predefined_File_Name
12555 -- Local variables
12560 -- Start of processing for Is_Iterator
12562 begin
12563 -- The type may be a subtype of a descendant of the proper instance of
12564 -- the predefined interface type, so we must use the root type of the
12565 -- given type. The same is done for Is_Reversible_Iterator.
12569 then
12578 else
12594 ----------------------------
12595 -- Is_Iterator_Over_Array --
12596 ----------------------------
12601 begin
12605 ------------
12606 -- Is_LHS --
12607 ------------
12609 -- We seem to have a lot of overlapping functions that do similar things
12610 -- (testing for left hand sides or lvalues???).
12615 begin
12616 -- Return True if we are the left hand side of an assignment statement
12621 else
12625 -- Case of prefix of indexed or selected component or slice
12629 then
12630 -- Here we have the case where the parent P is N.Q or N(Q .. R).
12631 -- If P is an LHS, then N is also effectively an LHS, but there
12632 -- is an important exception. If N is of an access type, then
12633 -- what we really have is N.all.Q (or N.all(Q .. R)). In either
12634 -- case this makes N.all a left hand side but not N itself.
12636 -- If we don't know the type yet, this is the case where we return
12637 -- Unknown, since the answer depends on the type which is unknown.
12642 -- We have an Etype set, so we can check it
12647 -- OK, not access type case, so just test whole expression
12649 else
12653 -- All other cases are not left hand sides
12655 else
12660 -----------------------------
12661 -- Is_Library_Level_Entity --
12662 -----------------------------
12665 begin
12666 -- The following is a small optimization, and it also properly handles
12667 -- discriminals, which in task bodies might appear in expressions before
12668 -- the corresponding procedure has been created, and which therefore do
12669 -- not have an assigned scope.
12675 -- Normal test is simply that the enclosing dynamic scope is Standard
12680 --------------------------------
12681 -- Is_Limited_Class_Wide_Type --
12682 --------------------------------
12685 begin
12686 return
12691 ---------------------------------
12692 -- Is_Local_Variable_Reference --
12693 ---------------------------------
12696 begin
12700 else
12701 declare
12704 begin
12707 else
12714 -----------------------------------------------
12715 -- Is_Nontrivial_Default_Init_Cond_Procedure --
12716 -----------------------------------------------
12718 function Is_Nontrivial_Default_Init_Cond_Procedure
12720 is
12724 begin
12727 then
12728 Body_Decl :=
12729 Unit_Declaration_Node
12732 -- The body of the Default_Initial_Condition procedure must contain
12733 -- at least one statement, otherwise the generation of the subprogram
12734 -- body failed.
12738 -- To qualify as nontrivial, the first statement of the procedure
12739 -- must be a check in the form of an if statement. If the original
12740 -- Default_Initial_Condition expression was folded, then the first
12741 -- statement is not a check.
12745 return
12753 -------------------------
12754 -- Is_Object_Reference --
12755 -------------------------
12759 -- Determine whether N is the name of an internally-generated renaming
12761 --------------------------------------
12762 -- Is_Internally_Generated_Renaming --
12763 --------------------------------------
12768 begin
12783 -- Start of processing for Is_Object_Reference
12785 begin
12789 else
12792 return
12796 -- In Ada 95, a function call is a constant object; a procedure
12797 -- call is not.
12802 -- Attributes 'Input, 'Loop_Entry, 'Old and 'Result produce
12803 -- objects.
12806 return
12808 Name_Loop_Entry,
12809 Name_Old,
12810 Name_Result);
12813 return
12815 and then
12822 -- A view conversion of a tagged object is an object reference
12829 -- An unchecked type conversion is considered to be an object if
12830 -- the operand is an object (this construction arises only as a
12831 -- result of expansion activities).
12836 -- Allow string literals to act as objects as long as they appear
12837 -- in internally-generated renamings. The expansion of iterators
12838 -- may generate such renamings when the range involves a string
12839 -- literal.
12844 -- AI05-0003: In Ada 2012 a qualified expression is a name.
12845 -- This allows disambiguation of function calls and the use
12846 -- of aggregates in more contexts.
12851 else
12862 -----------------------------------
12863 -- Is_OK_Variable_For_Out_Formal --
12864 -----------------------------------
12867 begin
12870 -- We must reject parenthesized variable names. Comes_From_Source is
12871 -- checked because there are currently cases where the compiler violates
12872 -- this rule (e.g. passing a task object to its controlled Initialize
12873 -- routine). This should be properly documented in sinfo???
12878 -- A variable is always allowed
12883 -- Generalized indexing operations are rewritten as explicit
12884 -- dereferences, and it is only during resolution that we can
12885 -- check whether the context requires an access_to_variable type.
12892 then
12895 -- Unchecked conversions are allowed only if they come from the
12896 -- generated code, which sometimes uses unchecked conversions for out
12897 -- parameters in cases where code generation is unaffected. We tell
12898 -- source unchecked conversions by seeing if they are rewrites of
12899 -- an original Unchecked_Conversion function call, or of an explicit
12900 -- conversion of a function call or an aggregate (as may happen in the
12901 -- expansion of a packed array aggregate).
12909 then
12915 else
12919 -- Normal type conversions are allowed if argument is a variable
12924 then
12928 -- We also allow a non-parenthesized expression that raises
12929 -- constraint error if it rewrites what used to be a variable
12934 then
12937 -- Type conversion of something other than a variable
12939 else
12943 -- If this node is rewritten, then test the original form, if that is
12944 -- OK, then we consider the rewritten node OK (for example, if the
12945 -- original node is a conversion, then Is_Variable will not be true
12946 -- but we still want to allow the conversion if it converts a variable).
12950 -- In Ada 2012, the explicit dereference may be a rewritten call to a
12951 -- Reference function.
12955 and then
12957 then
12959 -- Check that this is not a constant reference.
12964 return
12968 else
12972 -- All other non-variables are rejected
12974 else
12979 ------------------------------------
12980 -- Is_Package_Contract_Annotation --
12981 ------------------------------------
12986 begin
13000 -----------------------------------
13001 -- Is_Partially_Initialized_Type --
13002 -----------------------------------
13004 function Is_Partially_Initialized_Type
13007 is
13008 begin
13017 -- If component type is partially initialized, so is array type
13019 if Is_Partially_Initialized_Type
13021 then
13024 -- Otherwise we are only partially initialized if we are fully
13025 -- initialized (this is the empty array case, no point in us
13026 -- duplicating that code here).
13028 else
13034 -- A discriminated type is always partially initialized if in
13035 -- all mode
13040 -- A tagged type is always partially initialized
13045 -- Case of non-discriminated record
13047 else
13048 declare
13052 -- Set True if at least one component is present. If no
13053 -- components are present, then record type is fully
13054 -- initialized (another odd case, like the null array).
13056 begin
13057 -- Loop through components
13064 -- If a component has an initialization expression then
13065 -- the enclosing record type is partially initialized
13069 then
13072 -- If a component is of a type which is itself partially
13073 -- initialized, then the enclosing record type is also.
13075 elsif Is_Partially_Initialized_Type
13077 then
13085 -- No initialized components found. If we found any components
13086 -- they were all uninitialized so the result is false.
13091 -- But if we found no components, then all the components are
13092 -- initialized so we consider the type to be initialized.
13094 else
13100 -- Concurrent types are always fully initialized
13105 -- For a private type, go to underlying type. If there is no underlying
13106 -- type then just assume this partially initialized. Not clear if this
13107 -- can happen in a non-error case, but no harm in testing for this.
13110 declare
13112 begin
13115 else
13120 -- For any other type (are there any?) assume partially initialized
13122 else
13127 ------------------------------------
13128 -- Is_Potentially_Persistent_Type --
13129 ------------------------------------
13135 begin
13136 -- For private type, test corresponding full type
13141 -- Scalar types are potentially persistent
13146 -- Record type is potentially persistent if not tagged and the types of
13147 -- all it components are potentially persistent, and no component has
13148 -- an initialization expression.
13153 then
13158 else
13165 -- Array type is potentially persistent if its component type is
13166 -- potentially persistent and if all its constraints are static.
13177 else
13184 -- All other types are not potentially persistent
13186 else
13191 --------------------------------
13192 -- Is_Potentially_Unevaluated --
13193 --------------------------------
13199 begin
13203 -- A postcondition whose expression is a short-circuit is broken down
13204 -- into individual aspects for better exception reporting. The original
13205 -- short-circuit expression is rewritten as the second operand, and an
13206 -- occurrence of 'Old in that operand is potentially unevaluated.
13207 -- See Sem_ch13.adb for details of this transformation.
13214 N_Case_Expression,
13215 N_And_Then,
13216 N_Or_Else,
13217 N_In,
13218 N_Not_In)
13219 loop
13223 -- If the context is not an expression, or if is the result of
13224 -- expansion of an enclosing construct (such as another attribute)
13225 -- the predicate does not apply.
13229 then
13246 else
13251 ---------------------------------
13252 -- Is_Protected_Self_Reference --
13253 ---------------------------------
13258 -- Returns true if N belongs to an access definition
13260 --------------------------
13261 -- In_Access_Definition --
13262 --------------------------
13267 begin
13280 -- Start of processing for Is_Protected_Self_Reference
13282 begin
13283 -- Verify that prefix is analyzed and has the proper form. Note that
13284 -- the attributes Elab_Spec, Elab_Body and Elab_Subp_Body which also
13285 -- produce the address of an entity, do not analyze their prefix
13286 -- because they denote entities that are not necessarily visible.
13287 -- Neither of them can apply to a protected type.
13297 -----------------------------
13298 -- Is_RCI_Pkg_Spec_Or_Body --
13299 -----------------------------
13304 -- Return True if the unit of Cunit is an RCI package declaration
13306 ---------------------------
13307 -- Is_RCI_Pkg_Decl_Cunit --
13308 ---------------------------
13313 begin
13321 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
13323 begin
13325 or else
13330 -----------------------------------------
13331 -- Is_Remote_Access_To_Class_Wide_Type --
13332 -----------------------------------------
13334 function Is_Remote_Access_To_Class_Wide_Type
13336 is
13337 begin
13338 -- A remote access to class-wide type is a general access to object type
13339 -- declared in the visible part of a Remote_Types or Remote_Call_
13340 -- Interface unit.
13346 -----------------------------------------
13347 -- Is_Remote_Access_To_Subprogram_Type --
13348 -----------------------------------------
13350 function Is_Remote_Access_To_Subprogram_Type
13352 is
13353 begin
13360 --------------------
13361 -- Is_Remote_Call --
13362 --------------------
13365 begin
13368 -- An entry call cannot be remote
13374 then
13375 -- A subprogram declared in the spec of a RCI package is remote
13380 and then Is_Remote_Access_To_Subprogram_Type
13382 then
13383 -- The dereference of a RAS is a remote call
13388 and then Is_Remote_Access_To_Class_Wide_Type
13390 then
13391 -- Any primitive operation call with a controlling argument of
13392 -- a RACW type is a remote call.
13397 -- All other calls are local calls
13402 ----------------------
13403 -- Is_Renamed_Entry --
13404 ----------------------
13411 -- Determine whether Nam is an entry. Traverse selectors if there are
13412 -- nested selected components.
13414 --------------
13415 -- Is_Entry --
13416 --------------
13419 begin
13427 -- Start of processing for Is_Renamed_Entry
13429 begin
13434 -- Look for a rewritten subprogram renaming declaration
13438 then
13442 -- The rewritten subprogram is actually an entry
13447 then
13454 -----------------------------
13455 -- Is_Renaming_Declaration --
13456 -----------------------------
13459 begin
13461 when N_Exception_Renaming_Declaration |
13462 N_Generic_Function_Renaming_Declaration |
13463 N_Generic_Package_Renaming_Declaration |
13464 N_Generic_Procedure_Renaming_Declaration |
13465 N_Object_Renaming_Declaration |
13466 N_Package_Renaming_Declaration |
13467 N_Subprogram_Renaming_Declaration =>
13475 ----------------------------
13476 -- Is_Reversible_Iterator --
13477 ----------------------------
13484 begin
13487 and then Is_Predefined_File_Name
13489 then
13495 else
13502 and then
13503 Is_Predefined_File_Name
13505 then
13516 ----------------------
13517 -- Is_Selector_Name --
13518 ----------------------
13521 begin
13523 declare
13525 begin
13527 N_Generic_Association,
13528 N_Parameter_Association,
13529 N_Selected_Component)
13533 else
13534 declare
13537 begin
13540 or else
13547 ---------------------------------
13548 -- Is_Single_Concurrent_Object --
13549 ---------------------------------
13552 begin
13553 return
13557 -------------------------------
13558 -- Is_Single_Concurrent_Type --
13559 -------------------------------
13562 begin
13563 return
13565 and then Is_Single_Concurrent_Type_Declaration
13569 -------------------------------------------
13570 -- Is_Single_Concurrent_Type_Declaration --
13571 -------------------------------------------
13573 function Is_Single_Concurrent_Type_Declaration
13575 is
13576 begin
13578 N_Single_Task_Declaration);
13581 ---------------------------------------------
13582 -- Is_Single_Precision_Floating_Point_Type --
13583 ---------------------------------------------
13585 function Is_Single_Precision_Floating_Point_Type
13587 begin
13595 --------------------------------
13596 -- Is_Single_Protected_Object --
13597 --------------------------------
13600 begin
13601 return
13607 ---------------------------
13608 -- Is_Single_Task_Object --
13609 ---------------------------
13612 begin
13613 return
13619 -------------------------------------
13620 -- Is_SPARK_05_Initialization_Expr --
13621 -------------------------------------
13629 begin
13639 when N_Character_Literal |
13640 N_Integer_Literal |
13641 N_Real_Literal |
13642 N_String_Literal =>
13645 when N_Identifier |
13646 N_Expanded_Name =>
13649 then
13651 when E_Constant |
13652 E_Enumeration_Literal |
13653 E_Named_Integer |
13654 E_Named_Real =>
13659 else
13665 when N_Qualified_Expression |
13666 N_Type_Conversion =>
13672 when N_Binary_Op |
13673 N_Short_Circuit |
13674 N_Membership_Test =>
13676 and then
13679 when N_Aggregate |
13680 N_Extension_Aggregate =>
13682 Is_Ok :=
13700 -- Note: test for Present here needed for box assocation
13704 then
13727 -- Selected components might be expanded named not yet resolved, so
13728 -- default on the safe side. (Eg on sparklex.ads)
13741 ----------------------------------
13742 -- Is_SPARK_05_Object_Reference --
13743 ----------------------------------
13746 begin
13749 and then
13753 else
13764 -----------------------------
13765 -- Is_Specific_Tagged_Type --
13766 -----------------------------
13771 begin
13772 -- Handle private types
13776 else
13780 -- A specific tagged type is a non-class-wide tagged type
13785 ------------------
13786 -- Is_Statement --
13787 ------------------
13790 begin
13791 return
13796 ---------------------------------------
13797 -- Is_Subprogram_Contract_Annotation --
13798 ---------------------------------------
13800 function Is_Subprogram_Contract_Annotation
13802 is
13805 begin
13829 --------------------------------------------------
13830 -- Is_Subprogram_Stub_Without_Prior_Declaration --
13831 --------------------------------------------------
13833 function Is_Subprogram_Stub_Without_Prior_Declaration
13835 is
13836 begin
13837 -- A subprogram stub without prior declaration serves as declaration for
13838 -- the actual subprogram body. As such, it has an attached defining
13839 -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
13845 --------------------------
13846 -- Is_Suspension_Object --
13847 --------------------------
13850 begin
13851 -- This approach does an exact name match rather than to rely on
13852 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the
13853 -- front end at point where all auxiliary tables are locked and any
13854 -- modifications to them are treated as violations. Do not tamper with
13855 -- the tables, instead examine the Chars fields of all the scopes of Id.
13857 return
13867 ----------------------------
13868 -- Is_Synchronized_Object --
13869 ----------------------------
13874 begin
13877 -- The object is synchronized if it is of a type that yields a
13878 -- synchronized object.
13883 -- The object is synchronized if it is atomic and Async_Writers is
13884 -- enabled.
13889 -- A constant is a synchronized object by default
13894 -- A variable is a synchronized object if it is subject to pragma
13895 -- Constant_After_Elaboration.
13904 -- Otherwise the input is not an object or it does not qualify as a
13905 -- synchronized object.
13910 ---------------------------------
13911 -- Is_Synchronized_Tagged_Type --
13912 ---------------------------------
13917 begin
13918 -- A task or protected type derived from an interface is a tagged type.
13919 -- Such a tagged type is called a synchronized tagged type, as are
13920 -- synchronized interfaces and private extensions whose declaration
13921 -- includes the reserved word synchronized.
13925 or else
13927 or else
13930 or else
13937 -----------------
13938 -- Is_Transfer --
13939 -----------------
13944 begin
13946 or else
13947 Kind = N_Extended_Return_Statement
13948 or else
13949 Kind = N_Goto_Statement
13950 or else
13951 Kind = N_Raise_Statement
13952 or else
13953 Kind = N_Requeue_Statement
13954 then
13959 then
13966 then
13972 else
13977 -------------
13978 -- Is_True --
13979 -------------
13982 begin
13986 --------------------------------------
13987 -- Is_Unchecked_Conversion_Instance --
13988 --------------------------------------
13993 begin
13994 -- Look for a function whose generic parent is the predefined intrinsic
13995 -- function Unchecked_Conversion.
14000 return
14004 and then Is_Predefined_File_Name
14011 -------------------------------
14012 -- Is_Universal_Numeric_Type --
14013 -------------------------------
14016 begin
14020 ----------------------------
14021 -- Is_Variable_Size_Array --
14022 ----------------------------
14027 begin
14030 -- Check if some index is initialized with a non-constant value
14037 then
14048 -----------------------------
14049 -- Is_Variable_Size_Record --
14050 -----------------------------
14056 begin
14063 -- Recursive call if the record type has discriminants
14068 then
14073 then
14083 -----------------
14084 -- Is_Variable --
14085 -----------------
14087 function Is_Variable
14090 is
14094 -- Within a protected function, the private components of the enclosing
14095 -- protected type are constants. A function nested within a (protected)
14096 -- procedure is not itself protected. Within the body of a protected
14097 -- function the current instance of the protected type is a constant.
14100 -- Prefixes can involve implicit dereferences, in which case we must
14101 -- test for the case of a reference of a constant access type, which can
14102 -- can never be a variable.
14104 ---------------------------
14105 -- In_Protected_Function --
14106 ---------------------------
14112 begin
14113 -- E is the current instance of a type
14118 -- E is an object
14120 else
14127 else
14141 ------------------------
14142 -- Is_Variable_Prefix --
14143 ------------------------
14146 begin
14150 -- For the case of an indexed component whose prefix has a packed
14151 -- array type, the prefix has been rewritten into a type conversion.
14152 -- Determine variable-ness from the converted expression.
14158 then
14161 else
14166 -- Start of processing for Is_Variable
14168 begin
14169 -- Special check, allow x'Deref(expr) as a variable
14173 then
14177 -- Check if we perform the test on the original node since this may be a
14178 -- test of syntactic categories which must not be disturbed by whatever
14179 -- rewriting might have occurred. For example, an aggregate, which is
14180 -- certainly NOT a variable, could be turned into a variable by
14181 -- expansion.
14185 else
14189 -- Definitely OK if Assignment_OK is set. Since this is something that
14190 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
14195 -- Normally we go to the original node, but there is one exception where
14196 -- we use the rewritten node, namely when it is an explicit dereference.
14197 -- The generated code may rewrite a prefix which is an access type with
14198 -- an explicit dereference. The dereference is a variable, even though
14199 -- the original node may not be (since it could be a constant of the
14200 -- access type).
14202 -- In Ada 2005 we have a further case to consider: the prefix may be a
14203 -- function call given in prefix notation. The original node appears to
14204 -- be a selected component, but we need to examine the call.
14210 then
14211 -- Note that if the prefix is an explicit dereference that does not
14212 -- come from source, we must check for a rewritten function call in
14213 -- prefixed notation before other forms of rewriting, to prevent a
14214 -- compiler crash.
14216 return
14219 or else
14222 -- in Ada 2012, the dereference may have been added for a type with
14223 -- a declared implicit dereference aspect. Check that it is not an
14224 -- access to constant.
14230 then
14233 -- A function call is never a variable
14238 -- All remaining checks use the original node
14242 then
14243 declare
14247 begin
14256 -- Current instance of type. If this is a protected type, check
14257 -- we are not within the body of one of its protected functions.
14267 else
14275 or else
14279 -- For an explicit dereference, the type of the prefix cannot
14280 -- be an access to constant or an access to subprogram.
14283 declare
14285 begin
14291 -- The type conversion is the case where we do not deal with the
14292 -- context dependent special case of an actual parameter. Thus
14293 -- the type conversion is only considered a variable for the
14294 -- purposes of this routine if the target type is tagged. However,
14295 -- a type conversion is considered to be a variable if it does not
14296 -- come from source (this deals for example with the conversions
14297 -- of expressions to their actual subtypes).
14301 and then
14303 or else
14305 and then
14308 -- GNAT allows an unchecked type conversion as a variable. This
14309 -- only affects the generation of internal expanded code, since
14310 -- calls to instantiations of Unchecked_Conversion are never
14311 -- considered variables (since they are function calls).
14322 ---------------------------
14323 -- Is_Visibly_Controlled --
14324 ---------------------------
14328 begin
14334 --------------------------
14335 -- Is_Volatile_Function --
14336 --------------------------
14339 begin
14340 -- The caller must ensure that Func_Id denotes a function
14344 -- A protected function is automatically volatile
14350 then
14353 -- An instance of Ada.Unchecked_Conversion is a volatile function if
14354 -- either the source or the target are effectively volatile.
14358 then
14361 -- Otherwise the function is treated as volatile if it is subject to
14362 -- enabled pragma Volatile_Function.
14364 else
14365 return
14370 ------------------------
14371 -- Is_Volatile_Object --
14372 ------------------------
14377 -- If prefix is an implicit dereference, examine designated type
14380 -- Determines if given object has volatile components
14382 ------------------------
14383 -- Is_Volatile_Prefix --
14384 ------------------------
14389 begin
14391 declare
14394 begin
14399 else
14404 ------------------------------------
14405 -- Object_Has_Volatile_Components --
14406 ------------------------------------
14411 begin
14414 then
14420 then
14425 then
14428 else
14433 -- Start of processing for Is_Volatile_Object
14435 begin
14444 then
14449 then
14454 then
14457 else
14462 ---------------------------
14463 -- Itype_Has_Declaration --
14464 ---------------------------
14467 begin
14471 N_Subtype_Declaration)
14475 -------------------------
14476 -- Kill_Current_Values --
14477 -------------------------
14479 procedure Kill_Current_Values
14482 is
14483 begin
14493 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
14494 -- for a constant. Once the constant is elaborated, its value is
14495 -- not changed, therefore the associated flags that describe the
14496 -- value should not be modified either.
14501 -- Non-constant entities
14503 else
14510 -- Reset the Is_Known_Valid flag unless the type is always
14511 -- valid. This does not apply to a loop parameter because its
14512 -- bounds are defined by the loop header and therefore always
14513 -- valid.
14517 then
14529 -- Clear current value for entity E and all entities chained to E
14531 ------------------------------------------
14532 -- Kill_Current_Values_For_Entity_Chain --
14533 ------------------------------------------
14537 begin
14545 -- Start of processing for Kill_Current_Values
14547 begin
14548 -- Kill all saved checks, a special case of killing saved values
14551 Kill_All_Checks;
14554 -- Loop through relevant scopes, which includes the current scope and
14555 -- any parent scopes if the current scope is a block or a package.
14560 -- Clear current values of all entities in current scope
14564 -- If scope is a package, also clear current values of all private
14565 -- entities in the scope.
14569 then
14573 -- If this is a not a subprogram, deal with parents
14578 else
14584 --------------------------
14585 -- Kill_Size_Check_Code --
14586 --------------------------
14589 begin
14592 then
14598 --------------------------
14599 -- Known_To_Be_Assigned --
14600 --------------------------
14605 begin
14608 -- Test left side of assignment
14613 -- Function call arguments are never lvalues
14618 -- Positional parameter for procedure or accept call
14620 when N_Procedure_Call_Statement |
14621 N_Accept_Statement
14622 =>
14623 declare
14628 begin
14635 -- If we are not a list member, something is strange, so
14636 -- be conservative and return False.
14642 -- We are going to find the right formal by stepping forward
14643 -- through the formals, as we step backwards in the actuals.
14647 loop
14648 -- If no formal, something is weird, so be conservative
14649 -- and return False.
14663 -- Named parameter for procedure or accept call
14666 declare
14670 begin
14677 -- Loop through formals to find the one that matches
14680 loop
14681 -- If no matching formal, that's peculiar, some kind of
14682 -- previous error, so return False to be conservative.
14683 -- Actually this also happens in legal code in the case
14684 -- where P is a parameter association for an Extra_Formal???
14690 -- Else test for match
14700 -- Test for appearing in a conversion that itself appears
14701 -- in an lvalue context, since this should be an lvalue.
14706 -- All other references are definitely not known to be modifications
14714 ---------------------------
14715 -- Last_Source_Statement --
14716 ---------------------------
14721 begin
14731 ----------------------------------
14732 -- Matching_Static_Array_Bounds --
14733 ----------------------------------
14735 function Matching_Static_Array_Bounds
14738 is
14751 begin
14756 -- Unconstrained types do not have static bounds
14762 -- First treat specially the first dimension, as the lower bound and
14763 -- length of string literals are not stored like those of arrays.
14768 else
14773 and then
14775 then
14778 else
14781 else
14789 else
14794 and then
14796 then
14799 else
14802 else
14808 and then
14812 then
14814 else
14818 -- Then treat all other dimensions
14832 and then
14834 then
14836 else
14841 -- If we fall through the loop, all indexes matched
14846 -------------------
14847 -- May_Be_Lvalue --
14848 -------------------
14853 begin
14856 -- Test left side of assignment
14861 -- Test prefix of component or attribute. Note that the prefix of an
14862 -- explicit or implicit dereference cannot be an l-value.
14868 -- For an expanded name, the name is an lvalue if the expanded name
14869 -- is an lvalue, but the prefix is never an lvalue, since it is just
14870 -- the scope where the name is found.
14875 else
14879 -- For a selected component A.B, A is certainly an lvalue if A.B is.
14880 -- B is a little interesting, if we have A.B := 3, there is some
14881 -- discussion as to whether B is an lvalue or not, we choose to say
14882 -- it is. Note however that A is not an lvalue if it is of an access
14883 -- type since this is an implicit dereference.
14889 then
14891 else
14895 -- For an indexed component or slice, the index or slice bounds is
14896 -- never an lvalue. The prefix is an lvalue if the indexed component
14897 -- or slice is an lvalue, except if it is an access type, where we
14898 -- have an implicit dereference.
14903 then
14905 else
14909 -- Prefix of a reference is an lvalue if the reference is an lvalue
14914 -- Prefix of explicit dereference is never an lvalue
14919 -- Positional parameter for subprogram, entry, or accept call.
14920 -- In older versions of Ada function call arguments are never
14921 -- lvalues. In Ada 2012 functions can have in-out parameters.
14923 when N_Subprogram_Call |
14924 N_Entry_Call_Statement |
14925 N_Accept_Statement
14926 =>
14931 -- The following mechanism is clumsy and fragile. A single flag
14932 -- set in Resolve_Actuals would be preferable ???
14934 declare
14939 begin
14946 -- If we are not a list member, something is strange, so be
14947 -- conservative and return True.
14953 -- We are going to find the right formal by stepping forward
14954 -- through the formals, as we step backwards in the actuals.
14958 loop
14959 -- If no formal, something is weird, so be conservative and
14960 -- return True.
14974 -- Named parameter for procedure or accept call
14977 declare
14981 begin
14988 -- Loop through formals to find the one that matches
14991 loop
14992 -- If no matching formal, that's peculiar, some kind of
14993 -- previous error, so return True to be conservative.
14994 -- Actually happens with legal code for an unresolved call
14995 -- where we may get the wrong homonym???
15001 -- Else test for match
15011 -- Test for appearing in a conversion that itself appears in an
15012 -- lvalue context, since this should be an lvalue.
15017 -- Test for appearance in object renaming declaration
15022 -- All other references are definitely not lvalues
15030 -----------------------
15031 -- Mark_Coextensions --
15032 -----------------------
15036 -- Indicates whether the context causes nested coextensions to be
15037 -- dynamic or static
15040 -- Recognize an allocator node and label it as a dynamic coextension
15042 --------------------
15043 -- Mark_Allocator --
15044 --------------------
15047 begin
15052 -- If the allocator expression is potentially dynamic, it may
15053 -- be expanded out of order and require dynamic allocation
15054 -- anyway, so we treat the coextension itself as dynamic.
15055 -- Potential optimization ???
15059 then
15061 else
15071 -- Start of processing for Mark_Coextensions
15073 begin
15074 -- An allocator that appears on the right-hand side of an assignment is
15075 -- treated as a potentially dynamic coextension when the right-hand side
15076 -- is an allocator or a qualified expression.
15078 -- Obj := new ...'(new Coextension ...);
15081 Is_Dynamic :=
15083 N_Qualified_Expression);
15085 -- An allocator that appears within the expression of a simple return
15086 -- statement is treated as a potentially dynamic coextension when the
15087 -- expression is either aggregate, allocator, or qualified expression.
15089 -- return (new Coextension ...);
15090 -- return new ...'(new Coextension ...);
15093 Is_Dynamic :=
15095 N_Allocator,
15096 N_Qualified_Expression);
15098 -- An alloctor that appears within the initialization expression of an
15099 -- object declaration is considered a potentially dynamic coextension
15100 -- when the initialization expression is an allocator or a qualified
15101 -- expression.
15103 -- Obj : ... := new ...'(new Coextension ...);
15105 -- A similar case arises when the object declaration is part of an
15106 -- extended return statement.
15108 -- return Obj : ... := new ...'(new Coextension ...);
15109 -- return Obj : ... := (new Coextension ...);
15112 Is_Dynamic :=
15114 or else
15117 -- This routine should not be called with constructs that cannot contain
15118 -- coextensions.
15120 else
15127 ----------------------
15128 -- Needs_One_Actual --
15129 ----------------------
15134 begin
15135 -- Ada 2005 or later, and formals present
15149 -- Ada 83/95 or no formals
15151 else
15156 ------------------------
15157 -- New_Copy_List_Tree --
15158 ------------------------
15164 begin
15168 else
15181 --------------------------------------------------
15182 -- New_Copy_Tree Auxiliary Data and Subprograms --
15183 --------------------------------------------------
15188 -- Our approach here requires a two pass traversal of the tree. The
15189 -- first pass visits all nodes that eventually will be copied looking
15190 -- for defining Itypes. If any defining Itypes are found, then they are
15191 -- copied, and an entry is added to the replacement map. In the second
15192 -- phase, the tree is copied, using the replacement map to replace any
15193 -- Itype references within the copied tree.
15195 -- The following hash tables are used if the Map supplied has more
15196 -- than hash threshold entries to speed up access to the map. If
15197 -- there are fewer entries, then the map is searched sequentially
15198 -- (because setting up a hash table for only a few entries takes
15199 -- more time than it saves.
15202 -- Hash function used for hash operations
15204 -------------------
15205 -- New_Copy_Hash --
15206 -------------------
15209 begin
15213 ---------------
15214 -- NCT_Assoc --
15215 ---------------
15217 -- The hash table NCT_Assoc associates old entities in the table
15218 -- with their corresponding new entities (i.e. the pairs of entries
15219 -- presented in the original Map argument are Key-Element pairs).
15229 ---------------------
15230 -- NCT_Itype_Assoc --
15231 ---------------------
15233 -- The hash table NCT_Itype_Assoc contains entries only for those
15234 -- old nodes which have a non-empty Associated_Node_For_Itype set.
15235 -- The key is the associated node, and the element is the new node
15236 -- itself (NOT the associated node for the new node).
15246 -------------------
15247 -- New_Copy_Tree --
15248 -------------------
15250 function New_Copy_Tree
15255 is
15257 -- This is the actual map for the copy. It is initialized with the
15258 -- given elements, and then enlarged as required for Itypes that are
15259 -- copied during the first phase of the copy operation. The visit
15260 -- procedures add elements to this map as Itypes are encountered.
15261 -- The reason we cannot use Map directly, is that it may well be
15262 -- (and normally is) initialized to No_Elist, and if we have mapped
15263 -- entities, we have to reset it to point to a real Elist.
15266 -- Called during second phase to map entities into their corresponding
15267 -- copies using Actual_Map. If the argument is not an entity, or is not
15268 -- in Actual_Map, then it is returned unchanged.
15271 -- Builds hash tables (number of elements >= threshold value)
15273 function Copy_Elist_With_Replacement
15275 -- Called during second phase to copy element list doing replacements
15278 -- Called during the second phase to process a copied Itype. The actual
15279 -- copy happened during the first phase (so that we could make the entry
15280 -- in the mapping), but we still have to deal with the descendants of
15281 -- the copied Itype and copy them where necessary.
15284 -- Called during second phase to copy list doing replacements
15287 -- Called during second phase to copy node doing replacements
15290 -- Called during first phase to visit all elements of an Elist
15293 -- Visit a single field, recursing to call Visit_Node or Visit_List
15294 -- if the field is a syntactic descendant of the current node (i.e.
15295 -- its parent is Node N).
15298 -- Called during first phase to visit subsidiary fields of a defining
15299 -- Itype, and also create a copy and make an entry in the replacement
15300 -- map for the new copy.
15303 -- Called during first phase to visit all elements of a List
15306 -- Called during first phase to visit a node and all its subtrees
15308 -----------
15309 -- Assoc --
15310 -----------
15316 begin
15325 else
15329 -- No hash table used, do serial search
15331 else
15336 else
15345 ---------------------------
15346 -- Build_NCT_Hash_Tables --
15347 ---------------------------
15352 begin
15362 -- Get new entity, and associate old and new
15368 declare
15372 begin
15375 -- Enter a link between the associated node of the
15376 -- old Itype and the new Itype, for updating later
15377 -- when node is copied.
15391 ---------------------------------
15392 -- Copy_Elist_With_Replacement --
15393 ---------------------------------
15395 function Copy_Elist_With_Replacement
15397 is
15401 begin
15405 else
15418 ---------------------------------
15419 -- Copy_Itype_With_Replacement --
15420 ---------------------------------
15422 -- This routine exactly parallels its phase one analog Visit_Itype,
15425 begin
15426 -- Translate Next_Entity, Scope and Etype fields, in case they
15427 -- reference entities that have been mapped into copies.
15434 else
15438 -- Copy referenced fields
15446 Copy_Elist_With_Replacement
15452 First (Copy_List_With_Replacement
15458 Copy_Node_With_Replacement
15464 --------------------------------
15465 -- Copy_List_With_Replacement --
15466 --------------------------------
15468 function Copy_List_With_Replacement
15470 is
15474 begin
15478 else
15491 --------------------------------
15492 -- Copy_Node_With_Replacement --
15493 --------------------------------
15495 function Copy_Node_With_Replacement
15497 is
15500 procedure Adjust_Named_Associations
15503 -- If a call node has named associations, these are chained through
15504 -- the First_Named_Actual, Next_Named_Actual links. These must be
15505 -- propagated separately to the new parameter list, because these
15506 -- are not syntactic fields.
15508 function Copy_Field_With_Replacement
15510 -- Given Field, which is a field of Old_Node, return a copy of it
15511 -- if it is a syntactic field (i.e. its parent is Node), setting
15512 -- the parent of the copy to poit to New_Node. Otherwise returns
15513 -- the field (possibly mapped if it is an entity).
15515 -------------------------------
15516 -- Adjust_Named_Associations --
15517 -------------------------------
15519 procedure Adjust_Named_Associations
15522 is
15529 begin
15535 then
15538 then
15539 Set_First_Named_Actual
15543 -- Now scan parameter list from the beginning,to locate
15544 -- next named actual, which can be out of order.
15552 loop
15557 Set_Next_Named_Actual
15566 ---------------------------------
15567 -- Copy_Field_With_Replacement --
15568 ---------------------------------
15570 function Copy_Field_With_Replacement
15572 is
15573 begin
15578 declare
15582 begin
15583 -- If syntactic field, as indicated by the parent pointer
15584 -- being set, then copy the referenced node recursively.
15593 -- For semantic fields, update possible entity reference
15594 -- from the replacement map.
15596 else
15604 declare
15608 begin
15609 -- If syntactic field, as indicated by the parent pointer,
15610 -- then recursively copy the entire referenced list.
15616 -- For semantic list, just returned unchanged
15618 else
15625 -- Anything other than a list or a node is returned unchanged
15627 else
15632 -- Start of processing for Copy_Node_With_Replacement
15634 begin
15641 else
15644 -- If the node we are copying is the associated node of a
15645 -- previously copied Itype, then adjust the associated node
15646 -- of the copy of that Itype accordingly.
15649 declare
15653 begin
15654 -- Case of hash table used
15663 -- Case of no hash table used
15665 else
15669 and then
15671 then
15672 Set_Associated_Node_For_Itype
15682 -- Recursively copy descendants
15684 Set_Field1
15686 Set_Field2
15688 Set_Field3
15690 Set_Field4
15692 Set_Field5
15695 -- Adjust Sloc of new node if necessary
15700 -- If we adjust the Sloc, then we are essentially making
15701 -- a completely new node, so the Comes_From_Source flag
15702 -- should be reset to the proper default value.
15708 -- If the node is call and has named associations,
15709 -- set the corresponding links in the copy.
15713 or else
15716 then
15720 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
15721 -- The replacement mechanism applies to entities, and is not used
15722 -- here. Eventually we may need a more general graph-copying
15723 -- routine. For now, do a sequential search to find desired node.
15727 then
15728 declare
15732 begin
15746 -- All done, return copied node
15751 -----------------
15752 -- Visit_Elist --
15753 -----------------
15757 begin
15768 -----------------
15769 -- Visit_Field --
15770 -----------------
15773 begin
15779 -- Copy node if it is syntactic, i.e. its parent pointer is
15780 -- set to point to the field that referenced it (certain
15781 -- Itypes will also meet this criterion, which is fine, since
15782 -- these are clearly Itypes that do need to be copied, since
15783 -- we are copying their parent.)
15789 -- Another case, if we are pointing to an Itype, then we want
15790 -- to copy it if its associated node is somewhere in the tree
15791 -- being copied.
15793 -- Note: the exclusion of self-referential copies is just an
15794 -- optimization, since the search of the already copied list
15795 -- would catch it, but it is a common case (Etype pointing
15796 -- to itself for an Itype that is a base type).
15801 then
15802 declare
15805 begin
15811 else
15816 -- An Itype whose parent is not being copied definitely
15817 -- should NOT be copied, since it does not belong in any
15818 -- sense to the copied subtree.
15830 -----------------
15831 -- Visit_Itype --
15832 -----------------
15839 begin
15840 -- Itypes that describe the designated type of access to subprograms
15841 -- have the structure of subprogram declarations, with signatures,
15842 -- etc. Either we duplicate the signatures completely, or choose to
15843 -- share such itypes, which is fine because their elaboration will
15844 -- have no side effects.
15852 -- The new Itype has all the attributes of the old one, and
15853 -- we just copy the contents of the entity. However, the back-end
15854 -- needs different names for debugging purposes, so we create a
15855 -- new internal name for it in all cases.
15859 -- If our associated node is an entity that has already been copied,
15860 -- then set the associated node of the copy to point to the right
15861 -- copy. If we have copied an Itype that is itself the associated
15862 -- node of some previously copied Itype, then we set the right
15863 -- pointer in the other direction.
15867 -- Case of hash tables used
15881 -- If the hash table has no association for this Itype and
15882 -- its associated node, enter one now.
15884 else
15885 NCT_Itype_Assoc.Set
15889 -- Case of hash tables not used
15891 else
15895 Set_Associated_Node_For_Itype
15901 then
15902 Set_Associated_Node_For_Itype
15916 -- Add new association to map
15928 else
15932 Build_NCT_Hash_Tables;
15936 -- If a record subtype is simply copied, the entity list will be
15937 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
15943 -- Visit descendants that eventually get copied
15951 -- ??? This should involve call to Visit_Field
15958 Old_Itype);
15963 Old_Itype);
15968 ----------------
15969 -- Visit_List --
15970 ----------------
15974 begin
15985 ----------------
15986 -- Visit_Node --
15987 ----------------
15991 -- Start of processing for Visit_Node
15993 begin
15994 -- Handle case of an Itype, which must be copied
15998 -- Nothing to do if already in the list. This can happen with an
15999 -- Itype entity that appears more than once in the tree.
16000 -- Note that we do not want to visit descendants in this case.
16002 -- Test for already in list when hash table is used
16009 -- Test for already in list when hash table not used
16011 else
16012 declare
16014 begin
16020 else
16031 -- Visit descendants
16040 -- Start of processing for New_Copy_Tree
16042 begin
16045 -- See if we should use hash table
16050 else
16051 declare
16054 begin
16065 Build_NCT_Hash_Tables;
16066 else
16072 -- Hash table set up if required, now start phase one by visiting
16073 -- top node (we will recursively visit the descendants).
16077 -- Now the second phase of the copy can start. First we process
16078 -- all the mapped entities, copying their descendants.
16081 declare
16084 begin
16098 -- Now we can copy the actual tree
16103 -------------------------
16104 -- New_External_Entity --
16105 -------------------------
16107 function New_External_Entity
16115 is
16118 New_External_Name
16121 begin
16134 -------------------------
16135 -- New_Internal_Entity --
16136 -------------------------
16138 function New_Internal_Entity
16143 is
16146 begin
16158 -----------------
16159 -- Next_Actual --
16160 -----------------
16165 begin
16166 -- If we are pointing at a positional parameter, it is a member of a
16167 -- node list (the list of parameters), and the next parameter is the
16168 -- next node on the list, unless we hit a parameter association, then
16169 -- we shift to using the chain whose head is the First_Named_Actual in
16170 -- the parent, and then is threaded using the Next_Named_Actual of the
16171 -- Parameter_Association. All this fiddling is because the original node
16172 -- list is in the textual call order, and what we need is the
16173 -- declaration order.
16180 else
16184 else
16190 begin
16194 -----------------------
16195 -- Normalize_Actuals --
16196 -----------------------
16198 -- Chain actuals according to formals of subprogram. If there are no named
16199 -- associations, the chain is simply the list of Parameter Associations,
16200 -- since the order is the same as the declaration order. If there are named
16201 -- associations, then the First_Named_Actual field in the N_Function_Call
16202 -- or N_Procedure_Call_Statement node points to the Parameter_Association
16203 -- node for the parameter that comes first in declaration order. The
16204 -- remaining named parameters are then chained in declaration order using
16205 -- Next_Named_Actual.
16207 -- This routine also verifies that the number of actuals is compatible with
16208 -- the number and default values of formals, but performs no type checking
16209 -- (type checking is done by the caller).
16211 -- If the matching succeeds, Success is set to True and the caller proceeds
16212 -- with type-checking. If the match is unsuccessful, then Success is set to
16213 -- False, and the caller attempts a different interpretation, if there is
16214 -- one.
16216 -- If the flag Report is on, the call is not overloaded, and a failure to
16217 -- match can be reported here, rather than in the caller.
16219 procedure Normalize_Actuals
16224 is
16236 -- Add named actual at the proper place in the list, using the
16237 -- Next_Named_Actual link.
16240 -- Determines if an error is to be reported. To report an error, we
16241 -- need Report to be True, and also we do not report errors caused
16242 -- by calls to init procs that occur within other init procs. Such
16243 -- errors must always be cascaded errors, since if all the types are
16244 -- declared correctly, the compiler will certainly build decent calls.
16246 -----------
16247 -- Chain --
16248 -----------
16251 begin
16254 -- Call node points to first actual in list
16258 else
16266 ---------------
16267 -- Reporting --
16268 ---------------
16271 begin
16281 else
16286 -- Start of processing for Normalize_Actuals
16288 begin
16291 -- The name in the call is a function call that returns an access
16292 -- to subprogram. The designated type has the list of formals.
16295 else
16304 -- Find if there is a named association, and verify that no positional
16305 -- associations appear after named ones.
16313 loop
16320 -- Most common case: positional notation, no defaults
16327 -- Too many actuals: will not work
16332 else
16345 Error_Msg_N
16350 else
16364 -- Match the formals in order. If the corresponding actual is
16365 -- positional, nothing to do. Else scan the list of named actuals
16366 -- to find the one with the right name.
16370 then
16375 else
16376 -- For named parameters, search the list of actuals to find
16377 -- one that matches the next formal name.
16396 then
16401 then
16403 and then
16405 N_Function_Call,
16406 N_Parameter_Association)
16408 then
16411 else
16414 Error_Msg_NE
16422 -- Point to type derivation that generated the
16423 -- operation.
16427 Error_Msg_NE
16431 else
16432 Error_Msg_NE
16440 else
16453 else
16456 -- Find some superfluous named actual that did not get
16457 -- attached to the list of associations.
16464 then
16479 --------------------------------
16480 -- Note_Possible_Modification --
16481 --------------------------------
16490 begin
16491 -- Loop to find referenced entity, if there is one
16494 loop
16500 -- If the entity is missing, it is an undeclared identifier,
16501 -- and there is nothing to annotate.
16508 declare
16511 begin
16512 -- In formal verification mode, keep track of all reads and
16513 -- writes through explicit dereferences.
16521 then
16522 -- Case of a reference to an entry formal
16530 N_Reference
16531 then
16532 -- Case of a reference to a value on which side effects have
16533 -- been removed.
16538 else
16544 N_Unchecked_Type_Conversion)
16545 then
16550 N_Indexed_Component,
16551 N_Selected_Component)
16552 then
16553 -- Special check, if the prefix is an access type, then return
16554 -- since we are modifying the thing pointed to, not the prefix.
16555 -- When we are expanding, most usually the prefix is replaced
16556 -- by an explicit dereference, and this test is not needed, but
16557 -- in some cases (notably -gnatc mode and generics) when we do
16558 -- not do full expansion, we need this special test.
16563 -- Otherwise go to prefix and keep going
16565 else
16570 -- All other cases, not a modification
16572 else
16576 -- Now look for entity being referenced
16581 or else Modification_Comes_From_Source
16582 then
16583 -- Give warning if pragma unmodified given and we are
16584 -- sure this is a modification.
16601 -- Follow renaming chain
16605 then
16608 -- If the entity is the loop variable in an iteration over
16609 -- a container, retrieve container expression to indicate
16610 -- possible modification.
16614 N_Iterator_Specification
16615 then
16621 -- The expression may be the renaming of a subcomponent of an
16622 -- array or container. The assignment to the subcomponent is
16623 -- a modification of the container.
16627 N_Indexed_Component)
16628 then
16633 -- Generate a reference only if the assignment comes from
16634 -- source. This excludes, for example, calls to a dispatching
16635 -- assignment operation when the left-hand side is tagged. In
16636 -- GNATprove mode, we need those references also on generated
16637 -- code, as these are used to compute the local effects of
16638 -- subprograms.
16643 -- If the target of the assignment is the bound variable
16644 -- in an iterator, indicate that the corresponding array
16645 -- or container is also modified.
16649 then
16650 declare
16653 begin
16654 -- TBD : in the full version of the construct, the
16655 -- domain of iteration can be given by an expression.
16669 -- If we are sure this is a modification from source, and we know
16670 -- this modifies a constant, then give an appropriate warning.
16672 if Sure
16673 and then Modification_Comes_From_Source
16675 and then Address_Clause_Overlay_Warnings
16676 then
16677 declare
16682 begin
16686 Error_Msg_NE
16700 -------------------------
16701 -- Object_Access_Level --
16702 -------------------------
16704 -- Returns the static accessibility level of the view denoted by Obj. Note
16705 -- that the value returned is the result of a call to Scope_Depth. Only
16706 -- scope depths associated with dynamic scopes can actually be returned.
16707 -- Since only relative levels matter for accessibility checking, the fact
16708 -- that the distance between successive levels of accessibility is not
16709 -- always one is immaterial (invariant: if level(E2) is deeper than
16710 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
16714 -- Determine whether N is a construct of the form
16715 -- Some_Type (Operand._tag'Address)
16716 -- This construct appears in the context of dispatching calls.
16719 -- An explicit dereference is created when removing side-effects from
16720 -- expressions for constraint checking purposes. In this case a local
16721 -- access type is created for it. The correct access level is that of
16722 -- the original source node. We detect this case by noting that the
16723 -- prefix of the dereference is created by an object declaration whose
16724 -- initial expression is a reference.
16726 -----------------------------
16727 -- Is_Interface_Conversion --
16728 -----------------------------
16731 begin
16737 ------------------
16738 -- Reference_To --
16739 ------------------
16743 begin
16748 then
16750 else
16755 -- Local variables
16759 -- Start of processing for Object_Access_Level
16761 begin
16764 then
16767 else
16775 -- If E is a type then it denotes a current instance. For this case
16776 -- we add one to the normal accessibility level of the type to ensure
16777 -- that current instances are treated as always being deeper than
16778 -- than the level of any visible named access type (see 3.10.2(21)).
16786 -- Similarly, if E is a component of the current instance of a
16787 -- protected type, any instance of it is assumed to be at a deeper
16788 -- level than the type. For a protected object (whose type is an
16789 -- anonymous protected type) its components are at the same level
16790 -- as the type itself.
16795 then
16798 else
16799 -- Aliased formals of functions take their access level from the
16800 -- point of call, i.e. require a dynamic check. For static check
16801 -- purposes, this is smaller than the level of the subprogram
16802 -- itself. For procedures the aliased makes no difference.
16807 then
16810 else
16818 else
16825 else
16831 -- If the prefix is a selected access discriminant then we make a
16832 -- recursive call on the prefix, which will in turn check the level
16833 -- of the prefix object of the selected discriminant.
16835 -- In Ada 2012, if the discriminant has implicit dereference and
16836 -- the context is a selected component, treat this as an object of
16837 -- unknown scope (see below). This is necessary in compile-only mode;
16838 -- otherwise expansion will already have transformed the prefix into
16839 -- a temporary.
16843 and then
16845 and then
16849 then
16852 -- Detect an interface conversion in the context of a dispatching
16853 -- call. Use the original form of the conversion to find the access
16854 -- level of the operand.
16859 then
16863 declare
16865 begin
16868 else
16873 else
16882 -- Function results are objects, so we get either the access level of
16883 -- the function or, in the case of an indirect call, the level of the
16884 -- access-to-subprogram type. (This code is used for Ada 95, but it
16885 -- looks wrong, because it seems that we should be checking the level
16886 -- of the call itself, even for Ada 95. However, using the Ada 2005
16887 -- version of the code causes regressions in several tests that are
16888 -- compiled with -gnat95. ???)
16893 else
16897 -- For Ada 2005, the level of the result object of a function call is
16898 -- defined to be the level of the call's innermost enclosing master.
16899 -- We determine that by querying the depth of the innermost enclosing
16900 -- dynamic scope.
16902 else
16905 function Innermost_Master_Scope_Depth
16907 -- Returns the scope depth of the given node's innermost
16908 -- enclosing dynamic scope (effectively the accessibility
16909 -- level of the innermost enclosing master).
16911 ----------------------------------
16912 -- Innermost_Master_Scope_Depth --
16913 ----------------------------------
16915 function Innermost_Master_Scope_Depth
16917 is
16920 begin
16921 -- Locate the nearest enclosing node (by traversing Parents)
16922 -- that Defining_Entity can be applied to, and return the
16923 -- depth of that entity's nearest enclosing dynamic scope.
16927 when N_Component_Declaration |
16928 N_Entry_Declaration |
16929 N_Formal_Object_Declaration |
16930 N_Formal_Type_Declaration |
16931 N_Full_Type_Declaration |
16932 N_Incomplete_Type_Declaration |
16933 N_Loop_Parameter_Specification |
16934 N_Object_Declaration |
16935 N_Protected_Type_Declaration |
16936 N_Private_Extension_Declaration |
16937 N_Private_Type_Declaration |
16938 N_Subtype_Declaration |
16939 N_Function_Specification |
16940 N_Procedure_Specification |
16941 N_Task_Type_Declaration |
16942 N_Body_Stub |
16943 N_Generic_Instantiation |
16944 N_Proper_Body |
16945 N_Implicit_Label_Declaration |
16946 N_Package_Declaration |
16947 N_Single_Task_Declaration |
16948 N_Subprogram_Declaration |
16949 N_Generic_Declaration |
16950 N_Renaming_Declaration |
16951 N_Block_Statement |
16952 N_Formal_Subprogram_Declaration |
16953 N_Abstract_Subprogram_Declaration |
16954 N_Entry_Body |
16955 N_Exception_Declaration |
16956 N_Formal_Package_Declaration |
16957 N_Number_Declaration |
16958 N_Package_Specification |
16959 N_Parameter_Specification |
16960 N_Single_Protected_Declaration |
16961 N_Subunit =>
16963 return Scope_Depth
16964 (Nearest_Dynamic_Scope
16976 -- Should never reach the following return
16981 -- Start of processing for Return_Master_Scope_Depth_Of_Call
16983 begin
16988 -- For convenience we handle qualified expressions, even though they
16989 -- aren't technically object names.
16994 -- Ditto for aggregates. They have the level of the temporary that
16995 -- will hold their value.
17000 -- Otherwise return the scope level of Standard. (If there are cases
17001 -- that fall through to this point they will be treated as having
17002 -- global accessibility for now. ???)
17004 else
17009 ---------------------------------
17010 -- Original_Aspect_Pragma_Name --
17011 ---------------------------------
17017 begin
17022 -- The pragma was generated to emulate an aspect, use the original
17023 -- aspect specification.
17029 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class,
17030 -- Post and Post_Class rewrite their pragma identifier to preserve the
17031 -- original name.
17032 -- ??? this is kludgey
17037 else
17042 -- Deal with 'Class by converting the name to its _XXX form
17055 Name_Type_Invariant_Class)
17056 then
17059 -- Nothing to do for other cases (e.g. a Check that derived from
17060 -- Pre_Class and has the flag set). Also we do nothing if the name
17061 -- is already in special _xxx form.
17069 --------------------------------------
17070 -- Original_Corresponding_Operation --
17071 --------------------------------------
17074 is
17077 begin
17078 -- If S is an inherited primitive S2 the original corresponding
17079 -- operation of S is the original corresponding operation of S2
17083 then
17086 -- If S overrides an inherited subprogram S2 the original corresponding
17087 -- operation of S is the original corresponding operation of S2
17092 -- otherwise it is S itself
17094 else
17099 ----------------------
17100 -- Policy_In_Effect --
17101 ----------------------
17105 -- Determine the mode of a policy in a N_Pragma list
17107 --------------------
17108 -- Policy_In_List --
17109 --------------------
17116 begin
17125 -- The current Check_Policy pragma matches the requested policy or
17126 -- appears in the single argument form (Assertion, policy_id).
17138 -- Local variables
17142 -- Start of processing for Policy_In_Effect
17144 begin
17149 -- Inspect all policy pragmas that appear within scopes (if any)
17153 -- Inspect all configuration policy pragmas (if any)
17159 -- The context lacks policy pragmas, determine the mode based on whether
17160 -- assertions are enabled at the configuration level. This ensures that
17161 -- the policy is preserved when analyzing generics.
17166 else
17174 ----------------------------------
17175 -- Predicate_Tests_On_Arguments --
17176 ----------------------------------
17179 begin
17180 -- Always test predicates on indirect call
17185 -- Do not test predicates on call to generated default Finalize, since
17186 -- we are not interested in whether something we are finalizing (and
17187 -- typically destroying) satisfies its predicates.
17191 then
17194 -- Do not test predicates on any internally generated routines
17199 -- Do not test predicates on call to Init_Proc, since if needed the
17200 -- predicate test will occur at some other point.
17205 -- Do not test predicates on call to predicate function, since this
17206 -- would cause infinite recursion.
17210 or else
17212 then
17215 -- For now, no other exceptions
17217 else
17222 -----------------------
17223 -- Private_Component --
17224 -----------------------
17229 function Trace_Components
17232 -- Recursive function that does the work, and checks against circular
17233 -- definition for each subcomponent type.
17235 ----------------------
17236 -- Trace_Components --
17237 ----------------------
17239 function Trace_Components
17242 is
17248 begin
17258 then
17259 -- To indicate that the ancestor depends on a private type, the
17260 -- current Btype is sufficient. However, to check for circular
17261 -- definition we must recurse on the full view.
17267 else
17271 else
17282 loop
17283 -- Skip anonymous types generated by constrained components
17291 else
17302 else
17307 -- Start of processing for Private_Component
17309 begin
17313 ---------------------------
17314 -- Primitive_Names_Match --
17315 ---------------------------
17320 -- Given an internal name, returns the corresponding non-internal name
17322 ------------------------
17323 -- Non_Internal_Name --
17324 ------------------------
17327 begin
17333 -- Start of processing for Primitive_Names_Match
17335 begin
17339 or else
17343 or else
17347 or else
17351 or else
17355 -----------------------
17356 -- Process_End_Label --
17357 -----------------------
17359 procedure Process_End_Label
17363 is
17369 -- Set True if reference to end label itself is required
17372 -- Gets set to the operator symbol or identifier that references the
17373 -- entity Ent. For the child unit case, this is the identifier from the
17374 -- designator. For other cases, this is simply Endl.
17377 -- N is an identifier node that appears as a parent unit reference in
17378 -- the case where Ent is a child unit. This procedure generates an
17379 -- appropriate cross-reference entry. E is the corresponding entity.
17381 -------------------------
17382 -- Generate_Parent_Ref --
17383 -------------------------
17386 begin
17387 -- If names do not match, something weird, skip reference
17391 -- Generate the reference. We do NOT consider this as a reference
17392 -- for unreferenced symbol purposes.
17402 -- Start of processing for Process_End_Label
17404 begin
17405 -- If no node, ignore. This happens in some error situations, and
17406 -- also for some internally generated structures where no end label
17407 -- references are required in any case.
17413 -- Nothing to do if no End_Label, happens for internally generated
17414 -- constructs where we don't want an end label reference anyway. Also
17415 -- nothing to do if Endl is a string literal, which means there was
17416 -- some prior error (bad operator symbol)
17424 -- Reference node is not in extended main source unit
17428 -- Generally we do not collect references except for the extended
17429 -- main source unit. The one exception is the 'e' entry for a
17430 -- package spec, where it is useful for a client to have the
17431 -- ending information to define scopes.
17436 else
17439 -- For this case, we can ignore any parent references, but we
17440 -- need the package name itself for the 'e' entry.
17447 -- Reference is in extended main source unit
17449 else
17452 -- For designator, generate references for the parent entries
17456 -- Generate references for the prefix if the END line comes from
17457 -- source (otherwise we do not need these references) We climb the
17458 -- scope stack to find the expected entities.
17479 -- If the end label is not for the given entity, then either we have
17480 -- some previous error, or this is a generic instantiation for which
17481 -- we do not need to make a cross-reference in this case anyway. In
17482 -- either case we simply ignore the call.
17488 -- If label was really there, then generate a normal reference and then
17489 -- adjust the location in the end label to point past the name (which
17490 -- should almost always be the semicolon).
17496 -- If a label reference is required, then do the style check and
17497 -- generate an l-type cross-reference entry for the label
17507 -- Set the location to point past the label (normally this will
17508 -- mean the semicolon immediately following the label). This is
17509 -- done for the sake of the 'e' or 't' entry generated below.
17514 else
17515 -- In SPARK mode, no missing label is allowed for packages and
17516 -- subprogram bodies. Detect those cases by testing whether
17517 -- Process_End_Label was called for a body (Typ = 't') or a package.
17521 then
17523 Check_SPARK_05_Restriction
17528 -- Now generate the e/t reference
17532 -- Restore Sloc, in case modified above, since we have an identifier
17533 -- and the normal Sloc should be left set in the tree.
17538 ---------------------------------------
17539 -- Record_Possible_Part_Of_Reference --
17540 ---------------------------------------
17542 procedure Record_Possible_Part_Of_Reference
17545 is
17549 begin
17550 -- The variable is a constituent of a single protected/task type. Such
17551 -- a variable acts as a component of the type and must appear within a
17552 -- specific region (SPARK RM 9.3). Instead of recording the reference,
17553 -- verify its legality now.
17558 -- The variable is subject to pragma Part_Of and may eventually become a
17559 -- constituent of a single protected/task type. Record the reference to
17560 -- verify its placement when the contract of the variable is analyzed.
17574 ----------------
17575 -- Referenced --
17576 ----------------
17582 -- Determine whether node N denotes a reference to Id. If this is the
17583 -- case, set global flag Seen to True and stop the traversal.
17585 ------------------
17586 -- Is_Reference --
17587 ------------------
17590 begin
17594 then
17597 else
17604 -- Start of processing for Referenced
17606 begin
17611 ------------------------------------
17612 -- References_Generic_Formal_Type --
17613 ------------------------------------
17618 -- Process one node in search for generic formal type
17620 -------------
17621 -- Process --
17622 -------------
17625 begin
17627 declare
17629 begin
17635 then
17646 -- Traverse tree to look for generic type
17648 begin
17651 else
17656 --------------------
17657 -- Remove_Homonym --
17658 --------------------
17664 begin
17668 else
17672 else
17679 -- If E is not on the homonym chain, nothing to do
17687 ------------------------------
17688 -- Remove_Overloaded_Entity --
17689 ------------------------------
17693 -- Remove primitive subprogram Id from the list of primitives that
17694 -- belong to type Typ.
17696 -------------------------
17697 -- Remove_Primitive_Of --
17698 -------------------------
17703 begin
17713 -- Local variables
17719 -- Start of processing for Remove_Overloaded_Entity
17721 begin
17722 -- Remove the entity from the homonym chain. When the entity is the
17723 -- head of the chain, associate the entry in the name table with its
17724 -- homonym effectively making it the new head of the chain.
17729 -- Otherwise link the previous and next homonyms
17731 else
17740 -- Remove the entity from the scope entity chain. When the entity is
17741 -- the head of the chain, set the next entity as the new head of the
17742 -- chain.
17748 -- Otherwise the entity is either in the middle of the chain or it acts
17749 -- as its tail. Traverse and link the previous and next entities.
17751 else
17760 -- Handle the case where the entity acts as the tail of the scope entity
17761 -- chain.
17767 -- The entity denotes a primitive subprogram. Remove it from the list of
17768 -- primitives of the associated controlling type.
17787 ---------------------
17788 -- Rep_To_Pos_Flag --
17789 ---------------------
17792 begin
17793 return New_Occurrence_Of
17797 --------------------
17798 -- Require_Entity --
17799 --------------------
17802 begin
17806 else
17812 -------------------------------
17813 -- Requires_State_Refinement --
17814 -------------------------------
17816 function Requires_State_Refinement
17819 is
17821 -- Given pragma SPARK_Mode, determine whether the mode is Off
17823 -----------------
17824 -- Mode_Is_Off --
17825 -----------------
17830 begin
17831 -- The default SPARK mode is On
17839 -- Then the pragma lacks an argument, the default mode is On
17843 else
17848 -- Start of processing for Requires_State_Refinement
17850 begin
17851 -- A package that does not define at least one abstract state cannot
17852 -- possibly require refinement.
17857 -- The package instroduces a single null state which does not merit
17858 -- refinement.
17863 -- Check whether the package body is subject to pragma SPARK_Mode. If
17864 -- it is and the mode is Off, the package body is considered to be in
17865 -- regular Ada and does not require refinement.
17870 -- The body's SPARK_Mode may be inherited from a similar pragma that
17871 -- appears in the private declarations of the spec. The pragma we are
17872 -- interested appears as the second entry in SPARK_Pragma.
17876 then
17879 -- The spec defines at least one abstract state and the body has no way
17880 -- of circumventing the refinement.
17882 else
17887 ------------------------------
17888 -- Requires_Transient_Scope --
17889 ------------------------------
17891 -- A transient scope is required when variable-sized temporaries are
17892 -- allocated on the secondary stack, or when finalization actions must be
17893 -- generated before the next instruction.
17897 -- ???We retain the old and new algorithms for Requires_Transient_Scope for
17898 -- the time being. New_Requires_Transient_Scope is used by default; the
17899 -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
17900 -- instead. The intent is to use this temporarily to measure before/after
17901 -- efficiency. Note: when this temporary code is removed, the documentation
17902 -- of dQ in debug.adb should be removed.
17905 -- ???Debugging code. Called when the Old_ and New_ results differ. Will be
17906 -- removed when New_Requires_Transient_Scope becomes
17907 -- Requires_Transient_Scope and Old_Requires_Transient_Scope is eliminated.
17910 begin
17916 then
17925 begin
17930 declare
17933 begin
17934 -- Assert that we're not putting things on the secondary stack if we
17935 -- didn't before; we are trying to AVOID secondary stack when
17936 -- possible.
17951 ----------------------------------
17952 -- Old_Requires_Transient_Scope --
17953 ----------------------------------
17958 begin
17959 -- This is a private type which is not completed yet. This can only
17960 -- happen in a default expression (of a formal parameter or of a
17961 -- record component). Do not expand transient scope in this case.
17966 -- Do not expand transient scope for non-existent procedure return
17971 -- Elementary types do not require a transient scope
17976 -- Generally, indefinite subtypes require a transient scope, since the
17977 -- back end cannot generate temporaries, since this is not a valid type
17978 -- for declaring an object. It might be possible to relax this in the
17979 -- future, e.g. by declaring the maximum possible space for the type.
17984 -- Functions returning tagged types may dispatch on result so their
17985 -- returned value is allocated on the secondary stack. Controlled
17986 -- type temporaries need finalization.
17991 -- Record type
17994 declare
17997 begin
18002 -- ???It's not clear we need a full recursive call to
18003 -- Old_Requires_Transient_Scope here. Note that the
18004 -- following can't happen.
18020 -- String literal types never require transient scope
18025 -- Array type. Note that we already know that this is a constrained
18026 -- array, since unconstrained arrays will fail the indefinite test.
18030 -- If component type requires a transient scope, the array does too
18035 -- Otherwise, we only need a transient scope if the size depends on
18036 -- the value of one or more discriminants.
18038 else
18042 -- All other cases do not require a transient scope
18044 else
18050 ----------------------------------
18051 -- New_Requires_Transient_Scope --
18052 ----------------------------------
18057 -- This is called for untagged records and protected types, with
18058 -- nondefaulted discriminants. Returns True if the size of function
18059 -- results is known at the call site, False otherwise. Returns False
18060 -- if there is a variant part that depends on the discriminants of
18061 -- this type, or if there is an array constrained by the discriminants
18062 -- of this type. ???Currently, this is overly conservative (the array
18063 -- could be nested inside some other record that is constrained by
18064 -- nondiscriminants). That is, the recursive calls are too conservative.
18067 -- Returns True if Typ is a nonlimited record with defaulted
18068 -- discriminants whose max size makes it unsuitable for allocating on
18069 -- the primary stack.
18071 ------------------------------
18072 -- Caller_Known_Size_Record --
18073 ------------------------------
18078 begin
18083 declare
18086 begin
18090 -- Only look at E_Component entities. No need to look at
18091 -- E_Discriminant entities, and we must ignore internal
18092 -- subtypes generated for constrained components.
18095 declare
18099 begin
18101 or else
18103 then
18123 ------------------------------
18124 -- Large_Max_Size_Mutable --
18125 ------------------------------
18131 -- Returns true if the discrete type T has a large range
18133 ----------------------------
18134 -- Is_Large_Discrete_Type --
18135 ----------------------------
18139 -- Arbitrary threshold above which we consider it "large". We want
18140 -- a fairly large threshold, because these large types really
18141 -- shouldn't have default discriminants in the first place, in
18142 -- most cases.
18144 begin
18148 begin
18152 then
18153 -- Loop through the components, looking for an array whose upper
18154 -- bound(s) depends on discriminants, where both the subtype of
18155 -- the discriminant and the index subtype are too large.
18157 declare
18160 begin
18164 declare
18171 begin
18182 and then Is_Large_Discrete_Type
18184 then
18202 -- Local declarations
18206 -- Start of processing for New_Requires_Transient_Scope
18208 begin
18209 -- This is a private type which is not completed yet. This can only
18210 -- happen in a default expression (of a formal parameter or of a
18211 -- record component). Do not expand transient scope in this case.
18216 -- Do not expand transient scope for non-existent procedure return or
18217 -- string literal types.
18221 then
18224 -- If Typ is a generic formal incomplete type, then we want to look at
18225 -- the actual type.
18229 then
18232 -- Functions returning specific tagged types may dispatch on result, so
18233 -- their returned value is allocated on the secondary stack, even in the
18234 -- definite case. We must treat nondispatching functions the same way,
18235 -- because access-to-function types can point at both, so the calling
18236 -- conventions must be compatible. Is_Tagged_Type includes controlled
18237 -- types and class-wide types. Controlled type temporaries need
18238 -- finalization.
18240 -- ???It's not clear why we need to return noncontrolled types with
18241 -- controlled components on the secondary stack.
18246 -- Untagged definite subtypes are known size. This includes all
18247 -- elementary [sub]types. Tasks are known size even if they have
18248 -- discriminants. So we return False here, with one exception:
18249 -- For a type like:
18250 -- type T (Last : Natural := 0) is
18251 -- X : String (1 .. Last);
18252 -- end record;
18253 -- we return True. That's because for "P(F(...));", where F returns T,
18254 -- we don't know the size of the result at the call site, so if we
18255 -- allocated it on the primary stack, we would have to allocate the
18256 -- maximum size, which is way too big.
18261 -- Indefinite (discriminated) untagged record or protected type
18266 -- Unconstrained array
18268 else
18274 --------------------------
18275 -- Reset_Analyzed_Flags --
18276 --------------------------
18281 -- Function used to reset Analyzed flags in tree. Note that we do
18282 -- not reset Analyzed flags in entities, since there is no need to
18283 -- reanalyze entities, and indeed, it is wrong to do so, since it
18284 -- can result in generating auxiliary stuff more than once.
18286 --------------------
18287 -- Clear_Analyzed --
18288 --------------------
18291 begin
18301 -- Start of processing for Reset_Analyzed_Flags
18303 begin
18307 ------------------------
18308 -- Restore_SPARK_Mode --
18309 ------------------------
18312 begin
18316 --------------------------------
18317 -- Returns_Unconstrained_Type --
18318 --------------------------------
18321 begin
18328 ----------------------------
18329 -- Root_Type_Of_Full_View --
18330 ----------------------------
18335 begin
18336 -- The root type of the full view may itself be a private type. Keep
18337 -- looking for the ultimate derivation parent.
18341 else
18346 ---------------------------
18347 -- Safe_To_Capture_Value --
18348 ---------------------------
18350 function Safe_To_Capture_Value
18354 is
18355 begin
18356 -- The only entities for which we track constant values are variables
18357 -- which are not renamings, constants, out parameters, and in out
18358 -- parameters, so check if we have this case.
18360 -- Note: it may seem odd to track constant values for constants, but in
18361 -- fact this routine is used for other purposes than simply capturing
18362 -- the value. In particular, the setting of Known[_Non]_Null.
18365 or else
18367 then
18370 -- For conditionals, we also allow loop parameters and all formals,
18371 -- including in parameters.
18376 -- For all other cases, not just unsafe, but impossible to capture
18377 -- Current_Value, since the above are the only entities which have
18378 -- Current_Value fields.
18380 else
18384 -- Skip if volatile or aliased, since funny things might be going on in
18385 -- these cases which we cannot necessarily track. Also skip any variable
18386 -- for which an address clause is given, or whose address is taken. Also
18387 -- never capture value of library level variables (an attempt to do so
18388 -- can occur in the case of package elaboration code).
18396 then
18400 -- OK, all above conditions are met. We also require that the scope of
18401 -- the reference be the same as the scope of the entity, not counting
18402 -- packages and blocks and loops.
18404 declare
18408 begin
18415 else
18421 -- We also require that the reference does not appear in a context
18422 -- where it is not sure to be executed (i.e. a conditional context
18423 -- or an exception handler). We skip this if Cond is True, since the
18424 -- capturing of values from conditional tests handles this ok.
18430 declare
18434 begin
18437 -- Seems dubious that case expressions are not handled here ???
18452 then
18455 else
18459 -- A special Ada 2012 case: the original node may be part
18460 -- of the else_actions of a conditional expression, in which
18461 -- case it might not have been expanded yet, and appears in
18462 -- a non-syntactic list of actions. In that case it is clearly
18463 -- not safe to save a value.
18468 then
18475 -- OK, looks safe to set value
18480 ---------------
18481 -- Same_Name --
18482 ---------------
18488 begin
18491 then
18496 then
18500 else
18505 -----------------
18506 -- Same_Object --
18507 -----------------
18512 -- We do the tests on original nodes, since we are most interested
18513 -- in the original source, not any expansion that got in the way.
18518 begin
18519 -- First case, both are entities with same entity
18522 declare
18525 begin
18530 then
18536 -- Second case, selected component with same selector, same record
18541 then
18544 -- Third case, indexed component with same subscripts, same array
18549 then
18550 declare
18552 begin
18558 else
18567 -- Fourth case, slice of same array with same bounds
18577 then
18580 -- All other cases, not clearly the same object
18582 else
18587 ---------------
18588 -- Same_Type --
18589 ---------------
18592 begin
18599 then
18602 -- For now don't bother with case of identical constraints, to be
18603 -- fiddled with later on perhaps (this is only used for optimization
18604 -- purposes, so it is not critical to do a best possible job)
18606 else
18611 ----------------
18612 -- Same_Value --
18613 ----------------
18616 begin
18620 then
18624 else
18629 -----------------------------
18630 -- Save_SPARK_Mode_And_Set --
18631 -----------------------------
18633 procedure Save_SPARK_Mode_And_Set
18636 is
18637 begin
18638 -- Save the current mode in effect
18642 -- Do not consider illegal or partially decorated constructs
18652 -------------------------
18653 -- Scalar_Part_Present --
18654 -------------------------
18659 begin
18671 else
18680 ------------------------
18681 -- Scope_Is_Transient --
18682 ------------------------
18685 begin
18689 ------------------
18690 -- Scope_Within --
18691 ------------------
18696 begin
18709 --------------------------
18710 -- Scope_Within_Or_Same --
18711 --------------------------
18716 begin
18721 else
18729 --------------------
18730 -- Set_Convention --
18731 --------------------
18734 begin
18740 then
18742 -- A pragma Convention in an instance may apply to the subtype
18743 -- created for a formal, in which case we have already verified
18744 -- that conventions of actual and formal match and there is nothing
18745 -- to flag on the subtype.
18749 else
18754 -- If E is an object or component, and the type of E is an anonymous
18755 -- access type with no convention set, then also set the convention of
18756 -- the anonymous access type. We do not do this for anonymous protected
18757 -- types, since protected types always have the default convention.
18763 -- Allow E_Void (happens for pragma Convention appearing
18764 -- in the middle of a record applying to a component)
18767 then
18768 declare
18771 begin
18773 E_Anonymous_Access_Subprogram_Type)
18775 then
18779 -- And for the access subprogram type, deal similarly with the
18780 -- designated E_Subprogram_Type if it is also internal (which
18781 -- it always is?)
18784 declare
18786 begin
18790 then
18801 ------------------------
18802 -- Set_Current_Entity --
18803 ------------------------
18805 -- The given entity is to be set as the currently visible definition of its
18806 -- associated name (i.e. the Node_Id associated with its name). All we have
18807 -- to do is to get the name from the identifier, and then set the
18808 -- associated Node_Id to point to the given entity.
18811 begin
18815 ---------------------------
18816 -- Set_Debug_Info_Needed --
18817 ---------------------------
18823 -- Used to set debug info in a related node if not set already
18825 --------------------------------------
18826 -- Set_Debug_Info_Needed_If_Not_Set --
18827 --------------------------------------
18830 begin
18834 -- For a private type, indicate that the full view also needs
18835 -- debug information.
18840 then
18846 -- Start of processing for Set_Debug_Info_Needed
18848 begin
18849 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
18850 -- indicates that Debug_Info_Needed is never required for the entity.
18851 -- Nothing to do if entity comes from a predefined file. Library files
18852 -- are compiled without debug information, but inlined bodies of these
18853 -- routines may appear in user code, and debug information on them ends
18854 -- up complicating debugging the user code.
18858 then
18861 elsif In_Inlined_Body
18862 and then Is_Predefined_File_Name
18864 then
18868 -- Set flag in entity itself. Note that we will go through the following
18869 -- circuitry even if the flag is already set on T. That's intentional,
18870 -- it makes sure that the flag will be set in subsidiary entities.
18874 -- Set flag on subsidiary entities if not set already
18883 declare
18885 begin
18892 -- For a class wide subtype, we also need debug information
18893 -- for the equivalent type.
18902 declare
18904 begin
18911 -- For a packed array type, we also need debug information for
18912 -- the type used to represent the packed array. Conversely, we
18913 -- also need it for the former if we need it for the latter.
18927 declare
18930 begin
18933 -- If the full view is itself a derived private type, we need
18934 -- debug information on its underlying type.
18939 then
18949 -- If the subrange bounds are materialized by dedicated constant
18950 -- objects, also include them in the debug info to make sure the
18951 -- debugger can properly use them.
18955 then
18956 declare
18960 begin
18974 ----------------------------
18975 -- Set_Entity_With_Checks --
18976 ----------------------------
18983 begin
18984 -- Unconditionally set the entity
18988 -- The node to post on is the selector in the case of an expanded name,
18989 -- and otherwise the node itself.
18993 else
18997 -- Check for violation of No_Fixed_IO
19000 and then
19003 or else
19006 or else
19009 or else
19012 or else
19015 or else
19018 -- A special extra check, don't complain about a reference from within
19019 -- the Ada.Interrupts package itself!
19022 then
19026 -- Remaining checks are only done on source nodes. Note that we test
19027 -- for violation of No_Fixed_IO even on non-source nodes, because the
19028 -- cases for checking violations of this restriction are instantiations
19029 -- where the reference in the instance has Comes_From_Source False.
19035 -- Check for violation of No_Abort_Statements, which is triggered by
19036 -- call to Ada.Task_Identification.Abort_Task.
19041 -- A special extra check, don't complain about a reference from within
19042 -- the Ada.Task_Identification package itself!
19045 then
19053 -- Check for violation of No_Dynamic_Attachment
19065 -- A special extra check, don't complain about a reference from within
19066 -- the Ada.Interrupts package itself!
19069 then
19073 -- Check for No_Implementation_Identifiers
19077 -- We have an implementation defined entity if it is marked as
19078 -- implementation defined, or is defined in a package marked as
19079 -- implementation defined. However, library packages themselves
19080 -- are excluded (we don't want to flag Interfaces itself, just
19081 -- the entities within it).
19084 or else
19089 then
19094 -- Do the style check
19096 if Style_Check
19098 and then not In_Instance
19099 then
19104 else
19108 -- A special situation arises for derived operations, where we want
19109 -- to do the check against the parent (since the Sloc of the derived
19110 -- operation points to the derived type declaration itself).
19118 loop
19122 -- Renaming declarations for generic actuals do not come from source,
19123 -- and have a different name from that of the entity they rename, so
19124 -- there is no style check to perform here.
19134 ------------------------
19135 -- Set_Name_Entity_Id --
19136 ------------------------
19139 begin
19143 ---------------------
19144 -- Set_Next_Actual --
19145 ---------------------
19148 begin
19154 ----------------------------------
19155 -- Set_Optimize_Alignment_Flags --
19156 ----------------------------------
19159 begin
19167 -----------------------
19168 -- Set_Public_Status --
19169 -----------------------
19175 -- Determines if E is defined within handled statement sequence or
19176 -- an if statement, returns True if so, False otherwise.
19178 ----------------------
19179 -- Within_HSS_Or_If --
19180 ----------------------
19184 begin
19186 loop
19193 N_If_Statement)
19194 then
19200 -- Start of processing for Set_Public_Status
19202 begin
19203 -- Everything in the scope of Standard is public
19208 -- Entity is definitely not public if enclosing scope is not public
19213 -- An object or function declaration that occurs in a handled sequence
19214 -- of statements or within an if statement is the declaration for a
19215 -- temporary object or local subprogram generated by the expander. It
19216 -- never needs to be made public and furthermore, making it public can
19217 -- cause back end problems.
19220 N_Function_Specification)
19222 then
19225 -- Entities in public packages or records are public
19230 -- The bounds of an entry family declaration can generate object
19231 -- declarations that are visible to the back-end, e.g. in the
19232 -- the declaration of a composite type that contains tasks.
19237 then
19242 -----------------------------
19243 -- Set_Referenced_Modified --
19244 -----------------------------
19249 begin
19250 -- Deal with indexed or selected component where prefix is modified
19255 -- If prefix is access type, then it is the designated object that is
19256 -- being modified, which means we have no entity to set the flag on.
19261 -- Otherwise chase the prefix
19263 else
19267 -- Otherwise see if we have an entity name (only other case to process)
19275 ----------------------------
19276 -- Set_Scope_Is_Transient --
19277 ----------------------------
19280 begin
19284 -------------------
19285 -- Set_Size_Info --
19286 -------------------
19289 begin
19290 -- We copy Esize, but not RM_Size, since in general RM_Size is
19291 -- subtype specific and does not get inherited by all subtypes.
19297 and then
19299 then
19306 --------------------
19307 -- Static_Boolean --
19308 --------------------
19311 begin
19317 then
19324 else
19331 else
19332 Flag_Non_Static_Expr
19338 --------------------
19339 -- Static_Integer --
19340 --------------------
19343 begin
19349 then
19356 else
19363 else
19364 Flag_Non_Static_Expr
19370 --------------------------
19371 -- Statically_Different --
19372 --------------------------
19377 begin
19385 --------------------------------------
19386 -- Subject_To_Loop_Entry_Attributes --
19387 --------------------------------------
19392 begin
19395 -- The expansion mechanism transform a loop subject to at least one
19396 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
19397 -- the conditional part.
19401 then
19405 return
19412 -----------------------------
19413 -- Subprogram_Access_Level --
19414 -----------------------------
19417 begin
19420 else
19425 -------------------------------
19426 -- Support_Atomic_Primitives --
19427 -------------------------------
19432 begin
19433 -- Verify the alignment of Typ is known
19442 -- If the Esize (Object_Size) is unknown at compile time, look at the
19443 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
19448 -- Otherwise, the size is considered to be unknown.
19450 else
19454 -- Check that the size of the component is 8, 16, 32 or 64 bits and that
19455 -- Typ is properly aligned.
19465 -----------------
19466 -- Trace_Scope --
19467 -----------------
19470 begin
19480 Write_Eol;
19484 -----------------------
19485 -- Transfer_Entities --
19486 -----------------------
19490 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
19491 -- Set_Public_Status. If successfull and Id denotes a record type, set
19492 -- the Is_Public attribute of its fields.
19494 --------------------------
19495 -- Set_Public_Status_Of --
19496 --------------------------
19501 begin
19505 -- When the input entity is a public record type, ensure that all
19506 -- its internal fields are also exposed to the linker. The fields
19507 -- of a class-wide type are never made public.
19512 then
19522 -- Local variables
19527 -- Start of processing for Transfer_Entities
19529 begin
19534 -- Merge the entity chain of the source scope with that of the
19535 -- destination scope.
19539 else
19545 -- Inspect the entities of the source scope and update their Scope
19546 -- attribute.
19552 -- Handle an internally generated full view for a private type
19557 then
19572 -----------------------
19573 -- Type_Access_Level --
19574 -----------------------
19579 begin
19582 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
19583 -- simply use the level where the type is declared. This is true for
19584 -- stand-alone object declarations, and for anonymous access types
19585 -- associated with components the level is the same as that of the
19586 -- enclosing composite type. However, special treatment is needed for
19587 -- the cases of access parameters, return objects of an anonymous access
19588 -- type, and, in Ada 95, access discriminants of limited types.
19593 -- If the type is a nonlocal anonymous access type (such as for
19594 -- an access parameter) we treat it as being declared at the
19595 -- library level to ensure that names such as X.all'access don't
19596 -- fail static accessibility checks.
19601 -- If this is a return object, the accessibility level is that of
19602 -- the result subtype of the enclosing function. The test here is
19603 -- little complicated, because we have to account for extended
19604 -- return statements that have been rewritten as blocks, in which
19605 -- case we have to find and the Is_Return_Object attribute of the
19606 -- itype's associated object. It would be nice to find a way to
19607 -- simplify this test, but it doesn't seem worthwhile to add a new
19608 -- flag just for purposes of this test. ???
19611 or else
19614 N_Object_Declaration
19615 and then Is_Return_Object
19616 (Defining_Identifier
19618 then
19619 declare
19622 begin
19629 -- Treat the return object's type as having the level of the
19630 -- function's result subtype (as per RM05-6.5(5.3/2)).
19639 -- The accessibility level of anonymous access types associated with
19640 -- discriminants is that of the current instance of the type, and
19641 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
19643 -- AI-402: access discriminants have accessibility based on the
19644 -- object rather than the type in Ada 2005, so the above paragraph
19645 -- doesn't apply.
19647 -- ??? Needs completion with rules from AI-416
19653 N_Discriminant_Specification
19654 then
19659 -- Return library level for a generic formal type. This is done because
19660 -- RM(10.3.2) says that "The statically deeper relationship does not
19661 -- apply to ... a descendant of a generic formal type". Rather than
19662 -- checking at each point where a static accessibility check is
19663 -- performed to see if we are dealing with a formal type, this rule is
19664 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
19665 -- return extreme values for a formal type; Deepest_Type_Access_Level
19666 -- returns Int'Last. By calling the appropriate function from among the
19667 -- two, we ensure that the static accessibility check will pass if we
19668 -- happen to run into a formal type. More specifically, we should call
19669 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
19670 -- call occurs as part of a static accessibility check and the error
19671 -- case is the case where the type's level is too shallow (as opposed
19672 -- to too deep).
19681 ------------------------------------
19682 -- Type_Without_Stream_Operation --
19683 ------------------------------------
19685 function Type_Without_Stream_Operation
19688 is
19692 begin
19699 Op_Missing :=
19703 else
19709 else
19717 declare
19721 begin
19738 else
19743 ----------------------------
19744 -- Unique_Defining_Entity --
19745 ----------------------------
19748 begin
19752 -------------------
19753 -- Unique_Entity --
19754 -------------------
19760 begin
19769 declare
19771 begin
19772 -- Traverse the entity list of the protected type and locate
19773 -- an entry declaration which matches the entry body.
19779 then
19803 then
19808 then
19817 then
19822 then
19837 then
19842 then
19851 then
19856 then
19872 -----------------
19873 -- Unique_Name --
19874 -----------------
19878 -- Names of E_Subprogram_Body or E_Package_Body entities are not
19879 -- reliable, as they may not include the overloading suffix. Instead,
19880 -- when looking for the name of E or one of its enclosing scope, we get
19881 -- the name of the corresponding Unique_Entity.
19884 -- Return the name of E prefixed by all the names of the scopes to which
19885 -- E belongs, except for Standard.
19887 ---------------------
19888 -- Get_Scoped_Name --
19889 ---------------------
19893 begin
19896 then
19898 else
19903 -- Start of processing for Unique_Name
19905 begin
19911 then
19918 else
19923 ---------------------
19924 -- Unit_Is_Visible --
19925 ---------------------
19932 -- For a child unit, check whether unit appears in a with_clause
19933 -- of a parent.
19936 -- Scan the context clause of one compilation unit looking for a
19937 -- with_clause for the unit in question.
19939 ----------------------------
19940 -- Unit_In_Parent_Context --
19941 ----------------------------
19944 begin
19951 else
19956 ---------------------
19957 -- Unit_In_Context --
19958 ---------------------
19963 begin
19970 -- The with_clause may denote a renaming of the unit we are
19971 -- looking for, eg. Text_IO which renames Ada.Text_IO.
19973 elsif
19976 then
19987 -- Start of processing for Unit_Is_Visible
19989 begin
19990 -- The currrent unit is directly visible
19998 -- If the current unit is a body, check the context of the spec
20001 or else
20004 then
20010 -- If the spec is a child unit, examine the parents
20014 return
20015 Unit_In_Parent_Context
20017 else
20021 else
20026 ------------------------------
20027 -- Universal_Interpretation --
20028 ------------------------------
20034 begin
20035 -- The argument may be a formal parameter of an operator or subprogram
20036 -- with multiple interpretations, or else an expression for an actual.
20040 then
20043 then
20045 else
20049 else
20054 then
20065 ---------------
20066 -- Unqualify --
20067 ---------------
20070 begin
20071 -- Recurse to handle unlikely case of multiple levels of qualification
20076 -- Normal case, not a qualified expression
20078 else
20083 -----------------------
20084 -- Visible_Ancestors --
20085 -----------------------
20092 begin
20095 -- Collect all the parents and progenitors of Typ. If the full-view of
20096 -- private parents and progenitors is available then it is used to
20097 -- generate the list of visible ancestors; otherwise their partial
20098 -- view is added to the resulting list.
20100 Collect_Parents
20105 Collect_Interfaces
20111 -- Join the two lists. Avoid duplications because an interface may
20112 -- simultaneously be parent and progenitor of a type.
20123 ----------------------
20124 -- Within_Init_Proc --
20125 ----------------------
20130 begin
20135 else
20143 ------------------
20144 -- Within_Scope --
20145 ------------------
20149 begin
20151 loop
20156 else
20162 ----------------
20163 -- Wrong_Type --
20164 ----------------
20171 -- Entity to give a more precise suggestion on how to write a one-
20172 -- element positional aggregate.
20175 -- Determines if Expec_Type is a record type with a single component or
20176 -- discriminant whose type matches the found type or is one dimensional
20177 -- array whose component type matches the found type. In the case of
20178 -- one discriminant, we ignore the variant parts. That's not accurate,
20179 -- but good enough for the warning.
20181 ----------------------------
20182 -- Has_One_Matching_Field --
20183 ----------------------------
20188 begin
20194 then
20195 -- Use type name if available. This excludes multidimensional
20196 -- arrays and anonymous arrays.
20201 -- For an assignment, use name of target
20205 then
20214 else
20216 loop
20222 then
20225 else
20236 then
20239 else
20246 -- Start of processing for Wrong_Type
20248 begin
20249 -- Don't output message if either type is Any_Type, or if a message
20250 -- has already been posted for this node. We need to do the latter
20251 -- check explicitly (it is ordinarily done in Errout), because we
20252 -- are using ! to force the output of the error messages.
20257 then
20260 -- If one of the types is a Taft-Amendment type and the other it its
20261 -- completion, it must be an illegal use of a TAT in the spec, for
20262 -- which an error was already emitted. Avoid cascaded errors.
20267 then
20273 then
20276 -- In an instance, there is an ongoing problem with completion of
20277 -- type derived from private types. Their structure is what Gigi
20278 -- expects, but the Etype is the parent type rather than the
20279 -- derived private type itself. Do not flag error in this case. The
20280 -- private completion is an entity without a parent, like an Itype.
20281 -- Similarly, full and partial views may be incorrect in the instance.
20282 -- There is no simple way to insure that it is consistent ???
20284 -- A similar view discrepancy can happen in an inlined body, for the
20285 -- same reason: inserted body may be outside of the original package
20286 -- and only partial views are visible at the point of insertion.
20290 and then
20294 then
20299 then
20305 then
20308 -- Conversely, type of expression may be the private one
20312 then
20317 -- An interesting special check. If the expression is parenthesized
20318 -- and its type corresponds to the type of the sole component of the
20319 -- expected record type, or to the component type of the expected one
20320 -- dimensional array type, then assume we have a bad aggregate attempt.
20324 and then Has_One_Matching_Field
20325 then
20330 Error_Msg_NE
20332 else
20333 Error_Msg_NE
20338 -- Another special check, if we are looking for a pool-specific access
20339 -- type and we found an E_Access_Attribute_Type, then we have the case
20340 -- of an Access attribute being used in a context which needs a pool-
20341 -- specific type, which is never allowed. The one extra check we make
20342 -- is that the expected designated type covers the Found_Type.
20348 and then Covers
20350 then
20351 Error_Msg_N -- CODEFIX
20353 Error_Msg_NE -- CODEFIX
20356 -- Another special check, if the expected type is an integer type,
20357 -- but the expression is of type System.Address, and the parent is
20358 -- an addition or subtraction operation whose left operand is the
20359 -- expression in question and whose right operand is of an integral
20360 -- type, then this is an attempt at address arithmetic, so give
20361 -- appropriate message.
20368 then
20369 Error_Msg_N
20372 Error_Msg_N
20377 -- If the expected type is an anonymous access type, as for access
20378 -- parameters and discriminants, the error is on the designated types.
20383 else
20384 Error_Msg_NE
20391 then
20392 Error_Msg_NE
20395 else
20399 Error_Msg_NE -- CODEFIX
20402 else
20407 -- Normal case of one type found, some other type expected
20409 else
20410 -- If the names of the two types are the same, see if some number
20411 -- of levels of qualification will help. Don't try more than three
20412 -- levels, and if we get to standard, it's no use (and probably
20413 -- represents an error in the compiler) Also do not bother with
20414 -- internal scope names.
20416 declare
20420 begin
20442 then
20445 else
20451 then
20456 then
20458 Error_Msg_N
20460 Expr);
20461 else
20462 Error_Msg_N
20470 then
20471 Error_Msg_N
20473 Expr);
20475 -- Catch common error: a prefix or infix operator which is not
20476 -- directly visible because the type isn't.
20484 then
20485 Error_Msg_N
20491 then
20494 else
20498 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
20499 -- of the same modular type, and (M1 and M2) = 0 was intended.
20505 then
20506 declare
20511 begin
20512 -- The case for the message is when the left operand of the
20513 -- comparison is the same modular type, or when it is an
20514 -- integer literal (or other universal integer expression),
20515 -- which would have been typed as the modular type if the
20516 -- parens had been there.
20519 or else
20522 then
20523 Error_Msg_N
20529 -- Reset error message qualification indication
20535 --------------------------------
20536 -- Yields_Synchronized_Object --
20537 --------------------------------
20543 begin
20544 -- An array type yields a synchronized object if its component type
20545 -- yields a synchronized object.
20550 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
20551 -- yields a synchronized object by default.
20556 -- A protected type yields a synchronized object by default
20561 -- A record type or type extension yields a synchronized object when its
20562 -- discriminants (if any) lack default values and all components are of
20563 -- a type that yelds a synchronized object.
20567 -- Inspect all entities defined in the scope of the type, looking for
20568 -- components of a type that does not yeld a synchronized object or
20569 -- for discriminants with default values.
20578 -- The component does not yield a synchronized object
20580 else
20586 then
20594 -- Ensure that the parent type of a type extension yields a
20595 -- synchronized object.
20599 then
20603 -- If we get here, then all discriminants lack default values and all
20604 -- components are of a type that yields a synchronized object.
20608 -- A synchronized interface type yields a synchronized object by default
20613 -- A task type yelds a synchronized object by default
20618 -- Otherwise the type does not yield a synchronized object
20620 else