Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/sem_ch9.adb @ 131:84e7813d76e9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
4 -- -- 4 -- --
5 -- S E M _ C H 9 -- 5 -- S E M _ C H 9 --
6 -- -- 6 -- --
7 -- B o d y -- 7 -- B o d y --
8 -- -- 8 -- --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- 9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
10 -- -- 10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under -- 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- -- 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- -- 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- -- 14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
1208 P_Type : constant Entity_Id := Current_Scope; 1208 P_Type : constant Entity_Id := Current_Scope;
1209 E : Entity_Id; 1209 E : Entity_Id;
1210 Entry_Name : Entity_Id; 1210 Entry_Name : Entity_Id;
1211 1211
1212 begin 1212 begin
1213 -- An entry body "freezes" the contract of the nearest enclosing package 1213 -- An entry body freezes the contract of the nearest enclosing package
1214 -- body and all other contracts encountered in the same declarative part 1214 -- body and all other contracts encountered in the same declarative part
1215 -- up to and excluding the entry body. This ensures that any annotations 1215 -- up to and excluding the entry body. This ensures that any annotations
1216 -- referenced by the contract of an entry or subprogram body declared 1216 -- referenced by the contract of an entry or subprogram body declared
1217 -- within the current protected body are available. 1217 -- within the current protected body are available.
1218 1218
1219 Analyze_Previous_Contracts (N); 1219 Freeze_Previous_Contracts (N);
1220 1220
1221 Tasking_Used := True; 1221 Tasking_Used := True;
1222 1222
1223 -- Entry_Name is initialized to Any_Id. It should get reset to the 1223 -- Entry_Name is initialized to Any_Id. It should get reset to the
1224 -- matching entry entity. An error is signalled if it is not reset. 1224 -- matching entry entity. An error is signalled if it is not reset.
1244 Set_SPARK_Pragma_Inherited (Id); 1244 Set_SPARK_Pragma_Inherited (Id);
1245 1245
1246 -- Analyze any aspect specifications that appear on the entry body 1246 -- Analyze any aspect specifications that appear on the entry body
1247 1247
1248 if Has_Aspects (N) then 1248 if Has_Aspects (N) then
1249 Analyze_Aspect_Specifications_On_Body_Or_Stub (N); 1249 Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
1250 end if; 1250 end if;
1251 1251
1252 E := First_Entity (P_Type); 1252 E := First_Entity (P_Type);
1253 while Present (E) loop 1253 while Present (E) loop
1254 if Chars (E) = Chars (Id) 1254 if Chars (E) = Chars (Id)
1660 -- Preserve relevant elaboration-related attributes of the context which 1660 -- Preserve relevant elaboration-related attributes of the context which
1661 -- are no longer available or very expensive to recompute once analysis, 1661 -- are no longer available or very expensive to recompute once analysis,
1662 -- resolution, and expansion are over. 1662 -- resolution, and expansion are over.
1663 1663
1664 Mark_Elaboration_Attributes 1664 Mark_Elaboration_Attributes
1665 (N_Id => Def_Id, 1665 (N_Id => Def_Id,
1666 Checks => True); 1666 Checks => True,
1667 Warnings => True);
1667 1668
1668 -- Process formals 1669 -- Process formals
1669 1670
1670 if Present (Formals) then 1671 if Present (Formals) then
1671 Set_Scope (Def_Id, Current_Scope); 1672 Set_Scope (Def_Id, Current_Scope);
1792 end Lock_Free_Disabled; 1793 end Lock_Free_Disabled;
1793 1794
1794 -- Start of processing for Analyze_Protected_Body 1795 -- Start of processing for Analyze_Protected_Body
1795 1796
1796 begin 1797 begin
1797 -- A protected body "freezes" the contract of the nearest enclosing 1798 -- A protected body freezes the contract of the nearest enclosing
1798 -- package body and all other contracts encountered in the same 1799 -- package body and all other contracts encountered in the same
1799 -- declarative part up to and excluding the protected body. This ensures 1800 -- declarative part up to and excluding the protected body. This
1800 -- that any annotations referenced by the contract of an entry or 1801 -- ensures that any annotations referenced by the contract of an
1801 -- subprogram body declared within the current protected body are 1802 -- entry or subprogram body declared within the current protected
1802 -- available. 1803 -- body are available.
1803 1804
1804 Analyze_Previous_Contracts (N); 1805 Freeze_Previous_Contracts (N);
1805 1806
1806 Tasking_Used := True; 1807 Tasking_Used := True;
1807 Set_Ekind (Body_Id, E_Protected_Body); 1808 Set_Ekind (Body_Id, E_Protected_Body);
1808 Set_Etype (Body_Id, Standard_Void_Type); 1809 Set_Etype (Body_Id, Standard_Void_Type);
1809 Spec_Id := Find_Concurrent_Spec (Body_Id); 1810 Spec_Id := Find_Concurrent_Spec (Body_Id);
2285 It : Interp; 2286 It : Interp;
2286 Enclosing : Entity_Id; 2287 Enclosing : Entity_Id;
2287 Target_Obj : Node_Id := Empty; 2288 Target_Obj : Node_Id := Empty;
2288 Req_Scope : Entity_Id; 2289 Req_Scope : Entity_Id;
2289 Outer_Ent : Entity_Id; 2290 Outer_Ent : Entity_Id;
2290 Synch_Type : Entity_Id; 2291 Synch_Type : Entity_Id := Empty;
2291 2292
2292 begin 2293 begin
2293 -- Preserve relevant elaboration-related attributes of the context which 2294 -- Preserve relevant elaboration-related attributes of the context which
2294 -- are no longer available or very expensive to recompute once analysis, 2295 -- are no longer available or very expensive to recompute once analysis,
2295 -- resolution, and expansion are over. 2296 -- resolution, and expansion are over.
2296 2297
2297 Mark_Elaboration_Attributes 2298 Mark_Elaboration_Attributes
2298 (N_Id => N, 2299 (N_Id => N,
2299 Checks => True, 2300 Checks => True,
2300 Modes => True); 2301 Modes => True,
2302 Warnings => True);
2301 2303
2302 Tasking_Used := True; 2304 Tasking_Used := True;
2303 Check_SPARK_05_Restriction ("requeue statement is not allowed", N); 2305 Check_SPARK_05_Restriction ("requeue statement is not allowed", N);
2304 Check_Restriction (No_Requeue_Statements, N); 2306 Check_Restriction (No_Requeue_Statements, N);
2305 Check_Unreachable_Code (N); 2307 Check_Unreachable_Code (N);
2354 -- accept statement (or entry body). 2356 -- accept statement (or entry body).
2355 2357
2356 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) 2358 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
2357 and then 2359 and then
2358 (not Is_Entity_Name (Target_Obj) 2360 (not Is_Entity_Name (Target_Obj)
2359 or else Ekind (Entity (Target_Obj)) not in Formal_Kind 2361 or else not Is_Formal (Entity (Target_Obj))
2360 or else Enclosing /= Scope (Entity (Target_Obj))) 2362 or else Enclosing /= Scope (Entity (Target_Obj)))
2361 then 2363 then
2362 Error_Msg_N 2364 Error_Msg_N
2363 ("target object has invalid level for requeue", Target_Obj); 2365 ("target object has invalid level for requeue", Target_Obj);
2364 end if; 2366 end if;
2863 -- Preserve relevant elaboration-related attributes of the context which 2865 -- Preserve relevant elaboration-related attributes of the context which
2864 -- are no longer available or very expensive to recompute once analysis, 2866 -- are no longer available or very expensive to recompute once analysis,
2865 -- resolution, and expansion are over. 2867 -- resolution, and expansion are over.
2866 2868
2867 Mark_Elaboration_Attributes 2869 Mark_Elaboration_Attributes
2868 (N_Id => Obj_Id, 2870 (N_Id => Obj_Id,
2869 Checks => True); 2871 Checks => True,
2872 Warnings => True);
2870 2873
2871 -- Instead of calling Analyze on the new node, call the proper analysis 2874 -- Instead of calling Analyze on the new node, call the proper analysis
2872 -- procedure directly. Otherwise the node would be expanded twice, with 2875 -- procedure directly. Otherwise the node would be expanded twice, with
2873 -- disastrous result. 2876 -- disastrous result.
2874 2877
2898 -- This is the entity of the task or task type, and is the entity used 2901 -- This is the entity of the task or task type, and is the entity used
2899 -- for cross-reference purposes (it differs from Spec_Id in the case of 2902 -- for cross-reference purposes (it differs from Spec_Id in the case of
2900 -- a single task, since Spec_Id is set to the task type). 2903 -- a single task, since Spec_Id is set to the task type).
2901 2904
2902 begin 2905 begin
2903 -- A task body "freezes" the contract of the nearest enclosing package 2906 -- A task body freezes the contract of the nearest enclosing package
2904 -- body and all other contracts encountered in the same declarative part 2907 -- body and all other contracts encountered in the same declarative part
2905 -- up to and excluding the task body. This ensures that annotations 2908 -- up to and excluding the task body. This ensures that annotations
2906 -- referenced by the contract of an entry or subprogram body declared 2909 -- referenced by the contract of an entry or subprogram body declared
2907 -- within the current protected body are available. 2910 -- within the current protected body are available.
2908 2911
2909 Analyze_Previous_Contracts (N); 2912 Freeze_Previous_Contracts (N);
2910 2913
2911 Tasking_Used := True; 2914 Tasking_Used := True;
2912 Set_Scope (Body_Id, Current_Scope); 2915 Set_Scope (Body_Id, Current_Scope);
2913 Set_Ekind (Body_Id, E_Task_Body); 2916 Set_Ekind (Body_Id, E_Task_Body);
2914 Set_Etype (Body_Id, Standard_Void_Type); 2917 Set_Etype (Body_Id, Standard_Void_Type);
3134 -- Preserve relevant elaboration-related attributes of the context which 3137 -- Preserve relevant elaboration-related attributes of the context which
3135 -- are no longer available or very expensive to recompute once analysis, 3138 -- are no longer available or very expensive to recompute once analysis,
3136 -- resolution, and expansion are over. 3139 -- resolution, and expansion are over.
3137 3140
3138 Mark_Elaboration_Attributes 3141 Mark_Elaboration_Attributes
3139 (N_Id => T, 3142 (N_Id => T,
3140 Checks => True); 3143 Checks => True,
3144 Warnings => True);
3141 3145
3142 Push_Scope (T); 3146 Push_Scope (T);
3143 3147
3144 if Ada_Version >= Ada_2005 then 3148 if Ada_Version >= Ada_2005 then
3145 Check_Interfaces (N, T); 3149 Check_Interfaces (N, T);
3511 3515
3512 -- Additional checks on full-types associated with private type 3516 -- Additional checks on full-types associated with private type
3513 -- declarations. Search for the private type declaration. 3517 -- declarations. Search for the private type declaration.
3514 3518
3515 declare 3519 declare
3516 Full_T_Ifaces : Elist_Id; 3520 Full_T_Ifaces : Elist_Id := No_Elist;
3517 Iface : Node_Id; 3521 Iface : Node_Id;
3518 Priv_T : Entity_Id; 3522 Priv_T : Entity_Id;
3519 Priv_T_Ifaces : Elist_Id; 3523 Priv_T_Ifaces : Elist_Id := No_Elist;
3520 3524
3521 begin 3525 begin
3522 Priv_T := First_Entity (Scope (T)); 3526 Priv_T := First_Entity (Scope (T));
3523 loop 3527 loop
3524 pragma Assert (Present (Priv_T)); 3528 pragma Assert (Present (Priv_T));