Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/exp_ch8.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 -- E X P _ C H 8 -- 5 -- E X P _ C H 8 --
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- --
23 -- -- 23 -- --
24 ------------------------------------------------------------------------------ 24 ------------------------------------------------------------------------------
25 25
26 with Atree; use Atree; 26 with Atree; use Atree;
27 with Einfo; use Einfo; 27 with Einfo; use Einfo;
28 with Exp_Ch3; use Exp_Ch3;
28 with Exp_Ch4; use Exp_Ch4; 29 with Exp_Ch4; use Exp_Ch4;
29 with Exp_Ch6; use Exp_Ch6; 30 with Exp_Ch6; use Exp_Ch6;
30 with Exp_Dbug; use Exp_Dbug; 31 with Exp_Dbug; use Exp_Dbug;
31 with Exp_Util; use Exp_Util; 32 with Exp_Util; use Exp_Util;
32 with Freeze; use Freeze; 33 with Freeze; use Freeze;
33 with Namet; use Namet; 34 with Namet; use Namet;
34 with Nmake; use Nmake; 35 with Nmake; use Nmake;
35 with Nlists; use Nlists; 36 with Nlists; use Nlists;
36 with Opt; use Opt; 37 with Opt; use Opt;
37 with Sem; use Sem; 38 with Sem; use Sem;
39 with Sem_Aux; use Sem_Aux;
38 with Sem_Ch8; use Sem_Ch8; 40 with Sem_Ch8; use Sem_Ch8;
39 with Sem_Util; use Sem_Util; 41 with Sem_Util; use Sem_Util;
40 with Sinfo; use Sinfo; 42 with Sinfo; use Sinfo;
41 with Snames; use Snames; 43 with Snames; use Snames;
42 with Stand; use Stand; 44 with Stand; use Stand;
258 260
259 procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is 261 procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
260 Loc : constant Source_Ptr := Sloc (N); 262 Loc : constant Source_Ptr := Sloc (N);
261 Id : constant Entity_Id := Defining_Entity (N); 263 Id : constant Entity_Id := Defining_Entity (N);
262 264
263 function Build_Body_For_Renaming return Node_Id; 265 function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id;
264 -- Build and return the body for the renaming declaration of an equality 266 -- Build and return the body for the renaming declaration of an equality
265 -- or inequality operator. 267 -- or inequality operator of type Typ.
266 268
267 ----------------------------- 269 -----------------------------
268 -- Build_Body_For_Renaming -- 270 -- Build_Body_For_Renaming --
269 ----------------------------- 271 -----------------------------
270 272
271 function Build_Body_For_Renaming return Node_Id is 273 function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id is
274 Left : constant Entity_Id := First_Formal (Id);
275 Right : constant Entity_Id := Next_Formal (Left);
272 Body_Id : Entity_Id; 276 Body_Id : Entity_Id;
273 Decl : Node_Id; 277 Decl : Node_Id;
274 278
275 begin 279 begin
276 Set_Alias (Id, Empty); 280 Set_Alias (Id, Empty);
281 Set_Has_Delayed_Freeze (Id); 285 Set_Has_Delayed_Freeze (Id);
282 286
283 Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id)); 287 Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
284 Set_Debug_Info_Needed (Body_Id); 288 Set_Debug_Info_Needed (Body_Id);
285 289
286 Decl := 290 if Has_Variant_Part (Typ) then
287 Make_Subprogram_Body (Loc, 291 Decl :=
288 Specification => 292 Build_Variant_Record_Equality
289 Make_Function_Specification (Loc, 293 (Typ => Typ,
290 Defining_Unit_Name => Body_Id, 294 Body_Id => Body_Id,
291 Parameter_Specifications => Copy_Parameter_List (Id), 295 Param_Specs => Copy_Parameter_List (Id));
292 Result_Definition => 296
293 New_Occurrence_Of (Standard_Boolean, Loc)), 297 -- Build body for renamed equality, to capture its current meaning.
294 Declarations => Empty_List, 298 -- It may be redefined later, but the renaming is elaborated where
295 Handled_Statement_Sequence => Empty); 299 -- it occurs. This is technically known as Squirreling semantics.
300 -- Renaming is rewritten as a subprogram declaration, and the
301 -- generated body is inserted into the freeze actions for the
302 -- subprogram.
303
304 else
305 Decl :=
306 Make_Subprogram_Body (Loc,
307 Specification =>
308 Make_Function_Specification (Loc,
309 Defining_Unit_Name => Body_Id,
310 Parameter_Specifications => Copy_Parameter_List (Id),
311 Result_Definition =>
312 New_Occurrence_Of (Standard_Boolean, Loc)),
313 Declarations => Empty_List,
314 Handled_Statement_Sequence => Empty);
315
316 Set_Handled_Statement_Sequence (Decl,
317 Make_Handled_Sequence_Of_Statements (Loc,
318 Statements => New_List (
319 Make_Simple_Return_Statement (Loc,
320 Expression =>
321 Expand_Record_Equality
322 (Id,
323 Typ => Typ,
324 Lhs => Make_Identifier (Loc, Chars (Left)),
325 Rhs => Make_Identifier (Loc, Chars (Right)),
326 Bodies => Declarations (Decl))))));
327 end if;
296 328
297 return Decl; 329 return Decl;
298 end Build_Body_For_Renaming; 330 end Build_Body_For_Renaming;
299 331
300 -- Local variables 332 -- Local variables
326 if Is_Entity_Name (Nam) 358 if Is_Entity_Name (Nam)
327 and then Chars (Entity (Nam)) = Name_Op_Eq 359 and then Chars (Entity (Nam)) = Name_Op_Eq
328 and then Scope (Entity (Nam)) = Standard_Standard 360 and then Scope (Entity (Nam)) = Standard_Standard
329 then 361 then
330 declare 362 declare
331 Left : constant Entity_Id := First_Formal (Id); 363 Typ : constant Entity_Id := Etype (First_Formal (Id));
332 Right : constant Entity_Id := Next_Formal (Left);
333 Typ : constant Entity_Id := Etype (Left);
334 Decl : Node_Id;
335 364
336 begin 365 begin
337 -- Check whether this is a renaming of a predefined equality on an 366 -- Check whether this is a renaming of a predefined equality on an
338 -- untagged record type (AI05-0123). 367 -- untagged record type (AI05-0123).
339 368
340 if Ada_Version >= Ada_2012 369 if Ada_Version >= Ada_2012
341 and then Is_Record_Type (Typ) 370 and then Is_Record_Type (Typ)
342 and then not Is_Tagged_Type (Typ) 371 and then not Is_Tagged_Type (Typ)
343 and then not Is_Frozen (Typ) 372 and then not Is_Frozen (Typ)
344 then 373 then
345 -- Build body for renamed equality, to capture its current 374 Append_Freeze_Action (Id, Build_Body_For_Renaming (Typ));
346 -- meaning. It may be redefined later, but the renaming is
347 -- elaborated where it occurs. This is technically known as
348 -- Squirreling semantics. Renaming is rewritten as a subprogram
349 -- declaration, and the generated body is inserted into the
350 -- freeze actions for the subprogram.
351
352 Decl := Build_Body_For_Renaming;
353
354 Set_Handled_Statement_Sequence (Decl,
355 Make_Handled_Sequence_Of_Statements (Loc,
356 Statements => New_List (
357 Make_Simple_Return_Statement (Loc,
358 Expression =>
359 Expand_Record_Equality
360 (Id,
361 Typ => Typ,
362 Lhs => Make_Identifier (Loc, Chars (Left)),
363 Rhs => Make_Identifier (Loc, Chars (Right)),
364 Bodies => Declarations (Decl))))));
365
366 Append_Freeze_Action (Id, Decl);
367 end if; 375 end if;
368 end; 376 end;
369 end if; 377 end if;
370 end Expand_N_Subprogram_Renaming_Declaration; 378 end Expand_N_Subprogram_Renaming_Declaration;
371 379