This match modifies the expansion of array aggregates to perform in-place
side effect removal when a controlled function call acts as an initialization
expression. This eliminates the transient property of the function call and
ensures the proper order of copy, adjustment, and finalization.
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Ctrl is new Controlled with record
Id : Natural := 0;
end record;
procedure Adjust (Obj : in out Ctrl);
procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
function Make_Ctrl return Ctrl;
type Arr_1 is array (1 .. 10) of Ctrl;
type Arr_2 is array (Integer range <>) of Ctrl;
type Arr_3 is array (-10 .. -1) of Arr_1;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 100;
procedure Adjust (Obj : in out Ctrl) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id + 1;
begin
if Old_Id = 0 then
Put_Line ("ERROR: adjusting finalized object");
end if;
Put_Line (" adj" & Old_Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end Adjust;
procedure Finalize (Obj : in out Ctrl) is
begin
Put_Line (" fin" & Obj.Id'Img);
Obj.Id := 0;
end Finalize;
procedure Initialize (Obj : in out Ctrl) is
begin
Id_Gen := Id_Gen + 100;
Obj.Id := Id_Gen;
Put_Line (" ini" & Obj.Id'Img);
end Initialize;
function Make_Ctrl return Ctrl is
begin
return Result : Ctrl;
end Make_Ctrl;
end Types;
-- aggregates.ads
with Types; use Types;
package Aggregates is
function Func_4 (Build : Boolean) return Arr_3;
end Aggregates;
-- aggregats.adb
package body Aggregates is
function Func_4 (Build : Boolean) return Arr_3 is
begin
if Build then
return (-4 => -- 1) resolve 6) transient scope
(others => -- 2) resolve
Make_Ctrl), -- 13) transient scope
-1 =>
(others => -- 3) resolve
Make_Ctrl), -- 14) transient scope
-9 .. -5 =>
(others => -- 10) resolve 11) transient scope
Make_Ctrl), -- 12) transient scope
-10 =>
(1 .. 3 => -- 4) resolve
Make_Ctrl, -- 8) transient scope
4 =>
Make_Ctrl, -- 5) transient scope
others =>
Make_Ctrl), -- 9) transient scope
others =>
(1 .. 10 => -- 7) resolve 15) resolve 16) transient s
Make_Ctrl)); -- 17) transient scope
else
raise Program_Error;
end if;
end Func_4;
end Aggregates;
-- main.adb
with Ada.Finalization; use Ada.Finalization;
with Ada.Text_IO; use Ada.Text_IO;
with Aggregates; use Aggregates;
with Types; use Types;
procedure Main is
begin
Put_Line ("Complex mixed aggregate");
declare
Obj_4 : constant Arr_3 := Func_4 (True);
begin null; end;
Put_Line ("End");
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb
$ ./main
Complex mixed aggregate
ini 200
adj 200 -> 201
fin 200
ini 300
adj 300 -> 301
fin 300
adj 301 -> 302
fin 301
ini 400
adj 400 -> 401
fin 400
adj 401 -> 402
fin 401
ini 500
adj 500 -> 501
fin 500
adj 501 -> 502
fin 501
adj 201 -> 202
ini 600
adj 600 -> 601
fin 600
adj 601 -> 602
fin 601
ini 700
adj 700 -> 701
fin 700
adj 701 -> 702
fin 701
ini 800
adj 800 -> 801
fin 800
adj 801 -> 802
fin 801
ini 900
adj 900 -> 901
fin 900
adj 901 -> 902
fin 901
ini 1000
adj 1000 -> 1001
fin 1000
adj 1001 -> 1002
fin 1001
ini 1100
adj 1100 -> 1101
fin 1100
adj 1101 -> 1102
fin 1101
ini 1200
adj 1200 -> 1201
fin 1200
adj 1201 -> 1202
fin 1201
ini 1300
adj 1300 -> 1301
fin 1300
adj 1301 -> 1302
fin 1301
ini 1400
adj 1400 -> 1401
fin 1400
adj 1401 -> 1402
fin 1401
ini 1500
adj 1500 -> 1501
fin 1500
adj 1501 -> 1502
fin 1501
ini 1600
adj 1600 -> 1601
fin 1600
adj 1601 -> 1602
fin 1601
ini 1700
adj 1700 -> 1701
fin 1700
adj 1701 -> 1702
fin 1701
ini 1800
adj 1800 -> 1801
fin 1800
adj 1801 -> 1802
fin 1801
ini 1900
adj 1900 -> 1901
fin 1900
adj 1901 -> 1902
fin 1901
ini 2000
adj 2000 -> 2001
fin 2000
adj 2001 -> 2002
fin 2001
ini 2100
adj 2100 -> 2101
fin 2100
adj 2101 -> 2102
fin 2101
fin 2102
fin 2002
fin 1902
fin 1802
fin 1702
fin 1602
fin 1502
fin 1402
fin 1302
fin 1202
ini 2200
adj 2200 -> 2201
fin 2200
adj 2201 -> 2202
fin 2201
ini 2300
adj 2300 -> 2301
fin 2300
adj 2301 -> 2302
fin 2301
ini 2400
adj 2400 -> 2401
fin 2400
adj 2401 -> 2402
fin 2401
ini 2500
adj 2500 -> 2501
fin 2500
adj 2501 -> 2502
fin 2501
ini 2600
adj 2600 -> 2601
fin 2600
adj 2601 -> 2602
fin 2601
ini 2700
adj 2700 -> 2701
fin 2700
adj 2701 -> 2702
fin 2701
ini 2800
adj 2800 -> 2801
fin 2800
adj 2801 -> 2802
fin 2801
ini 2900
adj 2900 -> 2901
fin 2900
adj 2901 -> 2902
fin 2901
ini 3000
adj 3000 -> 3001
fin 3000
adj 3001 -> 3002
fin 3001
ini 3100
adj 3100 -> 3101
fin 3100
adj 3101 -> 3102
fin 3101
fin 3102
fin 3002
fin 2902
fin 2802
fin 2702
fin 2602
fin 2502
fin 2402
fin 2302
fin 2202
ini 3200
adj 3200 -> 3201
fin 3200
adj 3201 -> 3202
fin 3201
ini 3300
adj 3300 -> 3301
fin 3300
adj 3301 -> 3302
fin 3301
ini 3400
adj 3400 -> 3401
fin 3400
adj 3401 -> 3402
fin 3401
ini 3500
adj 3500 -> 3501
fin 3500
adj 3501 -> 3502
fin 3501
ini 3600
adj 3600 -> 3601
fin 3600
adj 3601 -> 3602
fin 3601
ini 3700
adj 3700 -> 3701
fin 3700
adj 3701 -> 3702
fin 3701
ini 3800
adj 3800 -> 3801
fin 3800
adj 3801 -> 3802
fin 3801
ini 3900
adj 3900 -> 3901
fin 3900
adj 3901 -> 3902
fin 3901
ini 4000
adj 4000 -> 4001
fin 4000
adj 4001 -> 4002
fin 4001
ini 4100
adj 4100 -> 4101
fin 4100
adj 4101 -> 4102
fin 4101
fin 4102
fin 4002
fin 3902
fin 3802
fin 3702
fin 3602
fin 3502
fin 3402
fin 3302
fin 3202
ini 4200
adj 4200 -> 4201
fin 4200
adj 4201 -> 4202
fin 4201
ini 4300
adj 4300 -> 4301
fin 4300
adj 4301 -> 4302
fin 4301
ini 4400
adj 4400 -> 4401
fin 4400
adj 4401 -> 4402
fin 4401
ini 4500
adj 4500 -> 4501
fin 4500
adj 4501 -> 4502
fin 4501
ini 4600
adj 4600 -> 4601
fin 4600
adj 4601 -> 4602
fin 4601
ini 4700
adj 4700 -> 4701
fin 4700
adj 4701 -> 4702
fin 4701
ini 4800
adj 4800 -> 4801
fin 4800
adj 4801 -> 4802
fin 4801
ini 4900
adj 4900 -> 4901
fin 4900
adj 4901 -> 4902
fin 4901
ini 5000
adj 5000 -> 5001
fin 5000
adj 5001 -> 5002
fin 5001
ini 5100
adj 5100 -> 5101
fin 5100
adj 5101 -> 5102
fin 5101
fin 5102
fin 5002
fin 4902
fin 4802
fin 4702
fin 4602
fin 4502
fin 4402
fin 4302
fin 4202
ini 5200
adj 5200 -> 5201
fin 5200
adj 5201 -> 5202
fin 5201
ini 5300
adj 5300 -> 5301
fin 5300
adj 5301 -> 5302
fin 5301
ini 5400
adj 5400 -> 5401
fin 5400
adj 5401 -> 5402
fin 5401
ini 5500
adj 5500 -> 5501
fin 5500
adj 5501 -> 5502
fin 5501
ini 5600
adj 5600 -> 5601
fin 5600
adj 5601 -> 5602
fin 5601
ini 5700
adj 5700 -> 5701
fin 5700
adj 5701 -> 5702
fin 5701
ini 5800
adj 5800 -> 5801
fin 5800
adj 5801 -> 5802
fin 5801
ini 5900
adj 5900 -> 5901
fin 5900
adj 5901 -> 5902
fin 5901
ini 6000
adj 6000 -> 6001
fin 6000
adj 6001 -> 6002
fin 6001
ini 6100
adj 6100 -> 6101
fin 6100
adj 6101 -> 6102
fin 6101
fin 6102
fin 6002
fin 5902
fin 5802
fin 5702
fin 5602
fin 5502
fin 5402
fin 5302
fin 5202
ini 6200
adj 6200 -> 6201
fin 6200
adj 6201 -> 6202
fin 6201
ini 6300
adj 6300 -> 6301
fin 6300
adj 6301 -> 6302
fin 6301
ini 6400
adj 6400 -> 6401
fin 6400
adj 6401 -> 6402
fin 6401
ini 6500
adj 6500 -> 6501
fin 6500
adj 6501 -> 6502
fin 6501
ini 6600
adj 6600 -> 6601
fin 6600
adj 6601 -> 6602
fin 6601
ini 6700
adj 6700 -> 6701
fin 6700
adj 6701 -> 6702
fin 6701
ini 6800
adj 6800 -> 6801
fin 6800
adj 6801 -> 6802
fin 6801
ini 6900
adj 6900 -> 6901
fin 6900
adj 6901 -> 6902
fin 6901
ini 7000
adj 7000 -> 7001
fin 7000
adj 7001 -> 7002
fin 7001
ini 7100
adj 7100 -> 7101
fin 7100
adj 7101 -> 7102
fin 7101
ini 7200
adj 7200 -> 7201
fin 7200
adj 7201 -> 7202
fin 7201
ini 7300
adj 7300 -> 7301
fin 7300
adj 7301 -> 7302
fin 7301
ini 7400
adj 7400 -> 7401
fin 7400
adj 7401 -> 7402
fin 7401
ini 7500
adj 7500 -> 7501
fin 7500
adj 7501 -> 7502
fin 7501
ini 7600
adj 7600 -> 7601
fin 7600
adj 7601 -> 7602
fin 7601
ini 7700
adj 7700 -> 7701
fin 7700
adj 7701 -> 7702
fin 7701
ini 7800
adj 7800 -> 7801
fin 7800
adj 7801 -> 7802
fin 7801
ini 7900
adj 7900 -> 7901
fin 7900
adj 7901 -> 7902
fin 7901
ini 8000
adj 8000 -> 8001
fin 8000
adj 8001 -> 8002
fin 8001
ini 8100
adj 8100 -> 8101
fin 8100
adj 8101 -> 8102
fin 8101
ini 8200
adj 8200 -> 8201
fin 8200
adj 8201 -> 8202
fin 8201
ini 8300
adj 8300 -> 8301
fin 8300
adj 8301 -> 8302
fin 8301
ini 8400
adj 8400 -> 8401
fin 8400
adj 8401 -> 8402
fin 8401
ini 8500
adj 8500 -> 8501
fin 8500
adj 8501 -> 8502
fin 8501
ini 8600
adj 8600 -> 8601
fin 8600
adj 8601 -> 8602
fin 8601
ini 8700
adj 8700 -> 8701
fin 8700
adj 8701 -> 8702
fin 8701
ini 8800
adj 8800 -> 8801
fin 8800
adj 8801 -> 8802
fin 8801
ini 8900
adj 8900 -> 8901
fin 8900
adj 8901 -> 8902
fin 8901
ini 9000
adj 9000 -> 9001
fin 9000
adj 9001 -> 9002
fin 9001
ini 9100
adj 9100 -> 9101
fin 9100
adj 9101 -> 9102
fin 9101
fin 9102
fin 9002
fin 8902
fin 8802
fin 8702
fin 8602
fin 8502
fin 8402
fin 8302
fin 8202
ini 9200
adj 9200 -> 9201
fin 9200
adj 9201 -> 9202
fin 9201
ini 9300
adj 9300 -> 9301
fin 9300
adj 9301 -> 9302
fin 9301
ini 9400
adj 9400 -> 9401
fin 9400
adj 9401 -> 9402
fin 9401
ini 9500
adj 9500 -> 9501
fin 9500
adj 9501 -> 9502
fin 9501
ini 9600
adj 9600 -> 9601
fin 9600
adj 9601 -> 9602
fin 9601
ini 9700
adj 9700 -> 9701
fin 9700
adj 9701 -> 9702
fin 9701
ini 9800
adj 9800 -> 9801
fin 9800
adj 9801 -> 9802
fin 9801
ini 9900
adj 9900 -> 9901
fin 9900
adj 9901 -> 9902
fin 9901
ini 10000
adj 10000 -> 10001
fin 10000
adj 10001 -> 10002
fin 10001
ini 10100
adj 10100 -> 10101
fin 10100
adj 10101 -> 10102
fin 10101
fin 10102
fin 10002
fin 9902
fin 9802
fin 9702
fin 9602
fin 9502
fin 9402
fin 9302
fin 9202
adj 302 -> 303
adj 402 -> 403
adj 502 -> 503
adj 202 -> 203
adj 602 -> 603
adj 702 -> 703
adj 802 -> 803
adj 902 -> 903
adj 1002 -> 1003
adj 1102 -> 1103
adj 1202 -> 1203
adj 1302 -> 1303
adj 1402 -> 1403
adj 1502 -> 1503
adj 1602 -> 1603
adj 1702 -> 1703
adj 1802 -> 1803
adj 1902 -> 1903
adj 2002 -> 2003
adj 2102 -> 2103
adj 2202 -> 2203
adj 2302 -> 2303
adj 2402 -> 2403
adj 2502 -> 2503
adj 2602 -> 2603
adj 2702 -> 2703
adj 2802 -> 2803
adj 2902 -> 2903
adj 3002 -> 3003
adj 3102 -> 3103
adj 3202 -> 3203
adj 3302 -> 3303
adj 3402 -> 3403
adj 3502 -> 3503
adj 3602 -> 3603
adj 3702 -> 3703
adj 3802 -> 3803
adj 3902 -> 3903
adj 4002 -> 4003
adj 4102 -> 4103
adj 4202 -> 4203
adj 4302 -> 4303
adj 4402 -> 4403
adj 4502 -> 4503
adj 4602 -> 4603
adj 4702 -> 4703
adj 4802 -> 4803
adj 4902 -> 4903
adj 5002 -> 5003
adj 5102 -> 5103
adj 5202 -> 5203
adj 5302 -> 5303
adj 5402 -> 5403
adj 5502 -> 5503
adj 5602 -> 5603
adj 5702 -> 5703
adj 5802 -> 5803
adj 5902 -> 5903
adj 6002 -> 6003
adj 6102 -> 6103
adj 6202 -> 6203
adj 6302 -> 6303
adj 6402 -> 6403
adj 6502 -> 6503
adj 6602 -> 6603
adj 6702 -> 6703
adj 6802 -> 6803
adj 6902 -> 6903
adj 7002 -> 7003
adj 7102 -> 7103
adj 8202 -> 8203
adj 8302 -> 8303
adj 8402 -> 8403
adj 8502 -> 8503
adj 8602 -> 8603
adj 8702 -> 8703
adj 8802 -> 8803
adj 8902 -> 8903
adj 9002 -> 9003
adj 9102 -> 9103
adj 9202 -> 9203
adj 9302 -> 9303
adj 9402 -> 9403
adj 9502 -> 9503
adj 9602 -> 9603
adj 9702 -> 9703
adj 9802 -> 9803
adj 9902 -> 9903
adj 10002 -> 10003
adj 10102 -> 10103
adj 7202 -> 7203
adj 7302 -> 7303
adj 7402 -> 7403
adj 7502 -> 7503
adj 7602 -> 7603
adj 7702 -> 7703
adj 7802 -> 7803
adj 7902 -> 7903
adj 8002 -> 8003
adj 8102 -> 8103
fin 8102
fin 8002
fin 7902
fin 7802
fin 7702
fin 7602
fin 7502
fin 7402
fin 7302
fin 7202
fin 10102
fin 10002
fin 9902
fin 9802
fin 9702
fin 9602
fin 9502
fin 9402
fin 9302
fin 9202
fin 9102
fin 9002
fin 8902
fin 8802
fin 8702
fin 8602
fin 8502
fin 8402
fin 8302
fin 8202
fin 7102
fin 7002
fin 6902
fin 6802
fin 6702
fin 6602
fin 6502
fin 6402
fin 6302
fin 6202
fin 6102
fin 6002
fin 5902
fin 5802
fin 5702
fin 5602
fin 5502
fin 5402
fin 5302
fin 5202
fin 5102
fin 5002
fin 4902
fin 4802
fin 4702
fin 4602
fin 4502
fin 4402
fin 4302
fin 4202
fin 4102
fin 4002
fin 3902
fin 3802
fin 3702
fin 3602
fin 3502
fin 3402
fin 3302
fin 3202
fin 3102
fin 3002
fin 2902
fin 2802
fin 2702
fin 2602
fin 2502
fin 2402
fin 2302
fin 2202
fin 2102
fin 2002
fin 1902
fin 1802
fin 1702
fin 1602
fin 1502
fin 1402
fin 1302
fin 1202
fin 1102
fin 1002
fin 902
fin 802
fin 702
fin 602
fin 202
fin 502
fin 402
fin 302
fin 201
adj 303 -> 304
adj 403 -> 404
adj 503 -> 504
adj 203 -> 204
adj 603 -> 604
adj 703 -> 704
adj 803 -> 804
adj 903 -> 904
adj 1003 -> 1004
adj 1103 -> 1104
adj 1203 -> 1204
adj 1303 -> 1304
adj 1403 -> 1404
adj 1503 -> 1504
adj 1603 -> 1604
adj 1703 -> 1704
adj 1803 -> 1804
adj 1903 -> 1904
adj 2003 -> 2004
adj 2103 -> 2104
adj 2203 -> 2204
adj 2303 -> 2304
adj 2403 -> 2404
adj 2503 -> 2504
adj 2603 -> 2604
adj 2703 -> 2704
adj 2803 -> 2804
adj 2903 -> 2904
adj 3003 -> 3004
adj 3103 -> 3104
adj 3203 -> 3204
adj 3303 -> 3304
adj 3403 -> 3404
adj 3503 -> 3504
adj 3603 -> 3604
adj 3703 -> 3704
adj 3803 -> 3804
adj 3903 -> 3904
adj 4003 -> 4004
adj 4103 -> 4104
adj 4203 -> 4204
adj 4303 -> 4304
adj 4403 -> 4404
adj 4503 -> 4504
adj 4603 -> 4604
adj 4703 -> 4704
adj 4803 -> 4804
adj 4903 -> 4904
adj 5003 -> 5004
adj 5103 -> 5104
adj 5203 -> 5204
adj 5303 -> 5304
adj 5403 -> 5404
adj 5503 -> 5504
adj 5603 -> 5604
adj 5703 -> 5704
adj 5803 -> 5804
adj 5903 -> 5904
adj 6003 -> 6004
adj 6103 -> 6104
adj 6203 -> 6204
adj 6303 -> 6304
adj 6403 -> 6404
adj 6503 -> 6504
adj 6603 -> 6604
adj 6703 -> 6704
adj 6803 -> 6804
adj 6903 -> 6904
adj 7003 -> 7004
adj 7103 -> 7104
adj 8203 -> 8204
adj 8303 -> 8304
adj 8403 -> 8404
adj 8503 -> 8504
adj 8603 -> 8604
adj 8703 -> 8704
adj 8803 -> 8804
adj 8903 -> 8904
adj 9003 -> 9004
adj 9103 -> 9104
adj 9203 -> 9204
adj 9303 -> 9304
adj 9403 -> 9404
adj 9503 -> 9504
adj 9603 -> 9604
adj 9703 -> 9704
adj 9803 -> 9804
adj 9903 -> 9904
adj 10003 -> 10004
adj 10103 -> 10104
adj 7203 -> 7204
adj 7303 -> 7304
adj 7403 -> 7404
adj 7503 -> 7504
adj 7603 -> 7604
adj 7703 -> 7704
adj 7803 -> 7804
adj 7903 -> 7904
adj 8003 -> 8004
adj 8103 -> 8104
fin 8103
fin 8003
fin 7903
fin 7803
fin 7703
fin 7603
fin 7503
fin 7403
fin 7303
fin 7203
fin 10103
fin 10003
fin 9903
fin 9803
fin 9703
fin 9603
fin 9503
fin 9403
fin 9303
fin 9203
fin 9103
fin 9003
fin 8903
fin 8803
fin 8703
fin 8603
fin 8503
fin 8403
fin 8303
fin 8203
fin 7103
fin 7003
fin 6903
fin 6803
fin 6703
fin 6603
fin 6503
fin 6403
fin 6303
fin 6203
fin 6103
fin 6003
fin 5903
fin 5803
fin 5703
fin 5603
fin 5503
fin 5403
fin 5303
fin 5203
fin 5103
fin 5003
fin 4903
fin 4803
fin 4703
fin 4603
fin 4503
fin 4403
fin 4303
fin 4203
fin 4103
fin 4003
fin 3903
fin 3803
fin 3703
fin 3603
fin 3503
fin 3403
fin 3303
fin 3203
fin 3103
fin 3003
fin 2903
fin 2803
fin 2703
fin 2603
fin 2503
fin 2403
fin 2303
fin 2203
fin 2103
fin 2003
fin 1903
fin 1803
fin 1703
fin 1603
fin 1503
fin 1403
fin 1303
fin 1203
fin 1103
fin 1003
fin 903
fin 803
fin 703
fin 603
fin 203
fin 503
fin 403
fin 303
fin 8104
fin 8004
fin 7904
fin 7804
fin 7704
fin 7604
fin 7504
fin 7404
fin 7304
fin 7204
fin 10104
fin 10004
fin 9904
fin 9804
fin 9704
fin 9604
fin 9504
fin 9404
fin 9304
fin 9204
fin 9104
fin 9004
fin 8904
fin 8804
fin 8704
fin 8604
fin 8504
fin 8404
fin 8304
fin 8204
fin 7104
fin 7004
fin 6904
fin 6804
fin 6704
fin 6604
fin 6504
fin 6404
fin 6304
fin 6204
fin 6104
fin 6004
fin 5904
fin 5804
fin 5704
fin 5604
fin 5504
fin 5404
fin 5304
fin 5204
fin 5104
fin 5004
fin 4904
fin 4804
fin 4704
fin 4604
fin 4504
fin 4404
fin 4304
fin 4204
fin 4104
fin 4004
fin 3904
fin 3804
fin 3704
fin 3604
fin 3504
fin 3404
fin 3304
fin 3204
fin 3104
fin 3004
fin 2904
fin 2804
fin 2704
fin 2604
fin 2504
fin 2404
fin 2304
fin 2204
fin 2104
fin 2004
fin 1904
fin 1804
fin 1704
fin 1604
fin 1504
fin 1404
fin 1304
fin 1204
fin 1104
fin 1004
fin 904
fin 804
fin 704
fin 604
fin 204
fin 504
fin 404
fin 304
End
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-07-04 Hristian Kirtchev <kirtc...@adacore.com>
* exp_aggr.adb (Ctrl_Init_Expression): New routine.
(Gen_Assign): Code cleanup. Perform in-place side effect removal when
the expression denotes a controlled function call.
* exp_util.adb (Remove_Side_Effects): Do not remove side effects
on a function call which has this behavior suppressed.
* sem_aggr.adb Code cleanup.
* sinfo.adb (No_Side_Effect_Removal): New routine.
(Set_Side_Effect_Removal): New routine.
* sinfo.ads New attribute No_Side_Effect_Removal along with
occurences in nodes.
(No_Side_Effect_Removal): New routine along with pragma Inline.
(Set_Side_Effect_Removal): New routine along with pragma Inline.
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb (revision 237957)
+++ sem_aggr.adb (working copy)
@@ -1821,6 +1821,25 @@
end if;
Step_2 : declare
+ function Empty_Range (A : Node_Id) return Boolean;
+ -- If an association covers an empty range, some warnings on the
+ -- expression of the association can be disabled.
+
+ -----------------
+ -- Empty_Range --
+ -----------------
+
+ function Empty_Range (A : Node_Id) return Boolean is
+ R : constant Node_Id := First (Choices (A));
+ begin
+ return No (Next (R))
+ and then Nkind (R) = N_Range
+ and then Compile_Time_Compare
+ (Low_Bound (R), High_Bound (R), False) = GT;
+ end Empty_Range;
+
+ -- Local variables
+
Low : Node_Id;
High : Node_Id;
-- Denote the lowest and highest values in an aggregate choice
@@ -1845,23 +1864,6 @@
Errors_Posted_On_Choices : Boolean := False;
-- Keeps track of whether any choices have semantic errors
- function Empty_Range (A : Node_Id) return Boolean;
- -- If an association covers an empty range, some warnings on the
- -- expression of the association can be disabled.
-
- -----------------
- -- Empty_Range --
- -----------------
-
- function Empty_Range (A : Node_Id) return Boolean is
- R : constant Node_Id := First (Choices (A));
- begin
- return No (Next (R))
- and then Nkind (R) = N_Range
- and then Compile_Time_Compare
- (Low_Bound (R), High_Bound (R), False) = GT;
- end Empty_Range;
-
-- Start of processing for Step_2
begin
@@ -3429,10 +3431,6 @@
-----------------------
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
- Expr_Type : Entity_Id := Empty;
- New_C : Entity_Id := Component;
- New_Expr : Node_Id;
-
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
-- If the expression is an aggregate (possibly qualified) then its
-- expansion is delayed until the enclosing aggregate is expanded
@@ -3442,15 +3440,6 @@
-- dynamic-sized aggregate in the code, something that gigi cannot
-- handle.
- Relocate : Boolean;
- -- Set to True if the resolved Expr node needs to be relocated when
- -- attached to the newly created association list. This node need not
- -- be relocated if its parent pointer is not set. In fact in this
- -- case Expr is the output of a New_Copy_Tree call. If Relocate is
- -- True then we have analyzed the expression node in the original
- -- aggregate and hence it needs to be relocated when moved over to
- -- the new association list.
-
---------------------------
-- Has_Expansion_Delayed --
---------------------------
@@ -3466,6 +3455,21 @@
and then Has_Expansion_Delayed (Expression (Expr)));
end Has_Expansion_Delayed;
+ -- Local variables
+
+ Expr_Type : Entity_Id := Empty;
+ New_C : Entity_Id := Component;
+ New_Expr : Node_Id;
+
+ Relocate : Boolean;
+ -- Set to True if the resolved Expr node needs to be relocated when
+ -- attached to the newly created association list. This node need not
+ -- be relocated if its parent pointer is not set. In fact in this
+ -- case Expr is the output of a New_Copy_Tree call. If Relocate is
+ -- True then we have analyzed the expression node in the original
+ -- aggregate and hence it needs to be relocated when moved over to
+ -- the new association list.
+
-- Start of processing for Resolve_Aggr_Expr
begin
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 237957)
+++ exp_util.adb (working copy)
@@ -7693,16 +7693,25 @@
and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
then
return;
- end if;
-- Cannot generate temporaries if the invocation to remove side effects
-- was issued too early and the type of the expression is not resolved
-- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
-- Remove_Side_Effects).
- if No (Exp_Type) or else Ekind (Exp_Type) = E_Access_Attribute_Type then
+ elsif No (Exp_Type)
+ or else Ekind (Exp_Type) = E_Access_Attribute_Type
+ then
return;
+ -- Nothing to do if prior expansion determined that a function call does
+ -- not require side effect removal.
+
+ elsif Nkind (Exp) = N_Function_Call
+ and then No_Side_Effect_Removal (Exp)
+ then
+ return;
+
-- No action needed for side-effect free expressions
elsif Check_Side_Effects
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 237957)
+++ sinfo.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2409,6 +2409,14 @@
return Flag17 (N);
end No_Minimize_Eliminate;
+ function No_Side_Effect_Removal
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call);
+ return Flag1 (N);
+ end No_Side_Effect_Removal;
+
function No_Truncation
(N : Node_Id) return Boolean is
begin
@@ -5664,6 +5672,14 @@
Set_Flag17 (N, Val);
end Set_No_Minimize_Eliminate;
+ procedure Set_No_Side_Effect_Removal
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call);
+ Set_Flag1 (N, Val);
+ end Set_No_Side_Effect_Removal;
+
procedure Set_No_Truncation
(N : Node_Id; Val : Boolean := True) is
begin
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 237957)
+++ sinfo.ads (working copy)
@@ -1946,6 +1946,12 @@
-- It is used to indicate that processing for extended overflow checking
-- modes is not required (this is used to prevent infinite recursion).
+ -- No_Side_Effect_Removal (Flag1-Sem)
+ -- Present in N_Function_Call nodes. Set when a function call does not
+ -- require side effect removal. This attribute suppresses the generation
+ -- of a temporary to capture the result of the function which eventually
+ -- replaces the function call.
+
-- No_Truncation (Flag17-Sem)
-- Present in N_Unchecked_Type_Conversion node. This flag has an effect
-- only if the RM_Size of the source is greater than the RM_Size of the
@@ -5296,6 +5302,7 @@
-- actual parameter part)
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+ -- No_Side_Effect_Removal (Flag1-Sem)
-- Is_Expanded_Build_In_Place_Call (Flag11-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- No_Elaboration_Check (Flag14-Sem)
@@ -9540,6 +9547,9 @@
function No_Minimize_Eliminate
(N : Node_Id) return Boolean; -- Flag17
+ function No_Side_Effect_Removal
+ (N : Node_Id) return Boolean; -- Flag1
+
function No_Truncation
(N : Node_Id) return Boolean; -- Flag17
@@ -10581,6 +10591,9 @@
procedure Set_No_Minimize_Eliminate
(N : Node_Id; Val : Boolean := True); -- Flag17
+ procedure Set_No_Side_Effect_Removal
+ (N : Node_Id; Val : Boolean := True); -- Flag1
+
procedure Set_No_Truncation
(N : Node_Id; Val : Boolean := True); -- Flag17
@@ -12877,6 +12890,7 @@
pragma Inline (No_Entities_Ref_In_Spec);
pragma Inline (No_Initialization);
pragma Inline (No_Minimize_Eliminate);
+ pragma Inline (No_Side_Effect_Removal);
pragma Inline (No_Truncation);
pragma Inline (Non_Aliased_Prefix);
pragma Inline (Null_Present);
@@ -13220,6 +13234,7 @@
pragma Inline (Set_No_Entities_Ref_In_Spec);
pragma Inline (Set_No_Initialization);
pragma Inline (Set_No_Minimize_Eliminate);
+ pragma Inline (Set_No_Side_Effect_Removal);
pragma Inline (Set_No_Truncation);
pragma Inline (Set_Non_Aliased_Prefix);
pragma Inline (Set_Null_Excluding_Subtype);
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb (revision 237957)
+++ exp_aggr.adb (working copy)
@@ -1017,19 +1017,20 @@
----------------
function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
- L : constant List_Id := New_List;
- A : Node_Id;
-
- New_Indexes : List_Id;
- Indexed_Comp : Node_Id;
- Expr_Q : Node_Id;
- Comp_Type : Entity_Id := Empty;
-
function Add_Loop_Actions (Lis : List_Id) return List_Id;
-- Collect insert_actions generated in the construction of a
-- loop, and prepend them to the sequence of assignments to
-- complete the eventual body of the loop.
+ function Ctrl_Init_Expression
+ (Comp_Typ : Entity_Id;
+ Stmts : List_Id) return Node_Id;
+ -- Perform in-place side effect removal if expression Expr denotes a
+ -- controlled function call. Return a reference to the entity which
+ -- captures the result of the call. Comp_Typ is the expected type of
+ -- the component. Stmts is the list of initialization statmenets. Any
+ -- generated code is added to Stmts.
+
----------------------
-- Add_Loop_Actions --
----------------------
@@ -1057,6 +1058,91 @@
end if;
end Add_Loop_Actions;
+ --------------------------
+ -- Ctrl_Init_Expression --
+ --------------------------
+
+ function Ctrl_Init_Expression
+ (Comp_Typ : Entity_Id;
+ Stmts : List_Id) return Node_Id
+ is
+ Init_Expr : Node_Id;
+ Obj_Id : Entity_Id;
+ Ptr_Typ : Entity_Id;
+
+ begin
+ Init_Expr := New_Copy_Tree (Expr);
+
+ -- Perform a preliminary analysis and resolution to determine
+ -- what the expression denotes. Note that a function call may
+ -- appear as an identifier or an indexed component.
+
+ Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
+
+ -- The initialization expression is a controlled function call.
+ -- Perform in-place removal of side effects to avoid creating a
+ -- transient scope. In the end the temporary function result is
+ -- finalized by the general finalization machinery.
+
+ if Nkind (Init_Expr) = N_Function_Call then
+
+ -- Suppress the removal of side effects by generatal analysis
+ -- because this behavior is emulated here.
+
+ Set_No_Side_Effect_Removal (Init_Expr);
+
+ -- Generate:
+ -- type Ptr_Typ is access all Comp_Typ;
+
+ Ptr_Typ := Make_Temporary (Loc, 'A');
+
+ Append_To (Stmts,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Comp_Typ, Loc))));
+
+ -- Generate:
+ -- Obj : constant Ptr_Typ := Init_Expr'Reference;
+
+ Obj_Id := Make_Temporary (Loc, 'R');
+
+ Append_To (Stmts,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
+ Expression => Make_Reference (Loc, Init_Expr)));
+
+ -- Generate:
+ -- Obj.all;
+
+ return
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc));
+
+ -- Otherwise the initialization expression denotes a controlled
+ -- object. There is nothing special to be done here as there is
+ -- no possible transient scope involvement.
+
+ else
+ return Init_Expr;
+ end if;
+ end Ctrl_Init_Expression;
+
+ -- Local variables
+
+ Stmts : constant List_Id := New_List;
+
+ Comp_Typ : Entity_Id := Empty;
+ Expr_Q : Node_Id;
+ Indexed_Comp : Node_Id;
+ New_Indexes : List_Id;
+ Stmt : Node_Id;
+ Stmt_Expr : Node_Id;
+
-- Start of processing for Gen_Assign
begin
@@ -1102,8 +1188,8 @@
end if;
if Present (Etype (N)) and then Etype (N) /= Any_Composite then
- Comp_Type := Component_Type (Etype (N));
- pragma Assert (Comp_Type = Ctype); -- AI-287
+ Comp_Typ := Component_Type (Etype (N));
+ pragma Assert (Comp_Typ = Ctype); -- AI-287
elsif Present (Next (First (New_Indexes))) then
@@ -1129,7 +1215,7 @@
if Nkind (P) = N_Aggregate
and then Present (Etype (P))
then
- Comp_Type := Component_Type (Etype (P));
+ Comp_Typ := Component_Type (Etype (P));
exit;
else
@@ -1137,7 +1223,7 @@
end if;
end loop;
- pragma Assert (Comp_Type = Ctype); -- AI-287
+ pragma Assert (Comp_Typ = Ctype); -- AI-287
end;
end if;
end if;
@@ -1155,8 +1241,8 @@
-- the analysis of non-array aggregates now in order to get the
-- value of Expansion_Delayed flag for the inner aggregate ???
- if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then
- Analyze_And_Resolve (Expr_Q, Comp_Type);
+ if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then
+ Analyze_And_Resolve (Expr_Q, Comp_Typ);
end if;
if Is_Delayed_Aggregate (Expr_Q) then
@@ -1171,9 +1257,9 @@
-- generated in the usual fashion, and sliding will take place.
if Nkind (Parent (N)) = N_Assignment_Statement
- and then Is_Array_Type (Comp_Type)
+ and then Is_Array_Type (Comp_Typ)
and then Present (Component_Associations (Expr_Q))
- and then Must_Slide (Comp_Type, Etype (Expr_Q))
+ and then Must_Slide (Comp_Typ, Etype (Expr_Q))
then
Set_Expansion_Delayed (Expr_Q, False);
Set_Analyzed (Expr_Q, False);
@@ -1201,7 +1287,7 @@
if Present (Base_Init_Proc (Base_Type (Ctype)))
or else Has_Task (Base_Type (Ctype))
then
- Append_List_To (L,
+ Append_List_To (Stmts,
Build_Initialization_Call (Loc,
Id_Ref => Indexed_Comp,
Typ => Ctype,
@@ -1214,28 +1300,81 @@
if Has_Invariants (Ctype) then
Set_Etype (Indexed_Comp, Ctype);
- Append_To (L, Make_Invariant_Call (Indexed_Comp));
+ Append_To (Stmts, Make_Invariant_Call (Indexed_Comp));
end if;
elsif Is_Access_Type (Ctype) then
- Append_To (L,
+ Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => Indexed_Comp,
+ Name => New_Copy_Tree (Indexed_Comp),
Expression => Make_Null (Loc)));
end if;
if Needs_Finalization (Ctype) then
- Append_To (L,
+ Append_To (Stmts,
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
Typ => Ctype));
end if;
else
- A :=
+ -- Handle an initialization expression of a controlled type in
+ -- case it denotes a function call. In general such a scenario
+ -- will produce a transient scope, but this will lead to wrong
+ -- order of initialization, adjustment, and finalization in the
+ -- context of aggregates.
+
+ -- Arr_Comp (1) := Ctrl_Func_Call;
+
+ -- begin -- transient scope
+ -- Trans_Obj : ... := Ctrl_Func_Call; -- transient object
+ -- Arr_Comp (1) := Trans_Obj;
+ -- Finalize (Trans_Obj);
+ -- end;
+ -- Arr_Comp (1)._tag := ...;
+ -- Adjust (Arr_Comp (1));
+
+ -- In the example above, the call to Finalize occurs too early
+ -- and as a result it may leave the array component in a bad
+ -- state. Finalization of the transient object should really
+ -- happen after adjustment.
+
+ -- To avoid this scenario, perform in-place side effect removal
+ -- of the function call. This eliminates the transient property
+ -- of the function result and ensures correct order of actions.
+ -- Note that the function result behaves as a source controlled
+ -- object and is finalized by the general finalization mechanism.
+
+ -- begin
+ -- Res : ... := Ctrl_Func_Call;
+ -- Arr_Comp (1) := Res;
+ -- Arr_Comp (1)._tag := ...;
+ -- Adjust (Arr_Comp (1));
+ -- at end
+ -- Finalize (Res);
+ -- end;
+
+ -- There is no need to perform this kind of light expansion when
+ -- the component type is limited controlled because everything is
+ -- already done in place.
+
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ and then not Is_Limited_Type (Comp_Typ)
+ and then Nkind (Expr) /= N_Aggregate
+ then
+ Stmt_Expr := Ctrl_Init_Expression (Comp_Typ, Stmts);
+
+ -- Otherwise use the initialization expression directly
+
+ else
+ Stmt_Expr := New_Copy_Tree (Expr);
+ end if;
+
+ Stmt :=
Make_OK_Assignment_Statement (Loc,
- Name => Indexed_Comp,
- Expression => New_Copy_Tree (Expr));
+ Name => New_Copy_Tree (Indexed_Comp),
+ Expression => Stmt_Expr);
-- The target of the assignment may not have been initialized,
-- so it is not possible to call Finalize as expected in normal
@@ -1248,7 +1387,7 @@
-- actions are done manually with the proper finalization list
-- coming from the context.
- Set_No_Ctrl_Actions (A);
+ Set_No_Ctrl_Actions (Stmt);
-- If this is an aggregate for an array of arrays, each
-- subaggregate will be expanded as well, and even with
@@ -1260,33 +1399,31 @@
-- that finalization takes place for each subaggregate we wrap the
-- assignment in a block.
- if Present (Comp_Type)
- and then Needs_Finalization (Comp_Type)
- and then Is_Array_Type (Comp_Type)
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ and then Is_Array_Type (Comp_Typ)
and then Present (Expr)
then
- A :=
+ Stmt :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (A)));
+ Statements => New_List (Stmt)));
end if;
- Append_To (L, A);
+ Append_To (Stmts, Stmt);
- -- Adjust the tag if tagged (because of possible view
- -- conversions), unless compiling for a VM where tags
- -- are implicit.
+ -- Adjust the tag due to a possible view conversion
- if Present (Comp_Type)
- and then Is_Tagged_Type (Comp_Type)
+ if Present (Comp_Typ)
+ and then Is_Tagged_Type (Comp_Typ)
and then Tagged_Type_Expansion
then
declare
- Full_Typ : constant Entity_Id := Underlying_Type (Comp_Type);
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
begin
- A :=
+ Append_To (Stmts,
Make_OK_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
@@ -1299,9 +1436,7 @@
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Full_Typ))),
- Loc)));
-
- Append_To (L, A);
+ Loc))));
end;
end if;
@@ -1316,22 +1451,22 @@
-- (see comments above, concerning the creation of a block to hold
-- inner finalization actions).
- if Present (Comp_Type)
- and then Needs_Finalization (Comp_Type)
- and then not Is_Limited_Type (Comp_Type)
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ and then not Is_Limited_Type (Comp_Typ)
and then not
- (Is_Array_Type (Comp_Type)
- and then Is_Controlled (Component_Type (Comp_Type))
+ (Is_Array_Type (Comp_Typ)
+ and then Is_Controlled (Component_Type (Comp_Typ))
and then Nkind (Expr) = N_Aggregate)
then
- Append_To (L,
+ Append_To (Stmts,
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Comp_Type));
+ Typ => Comp_Typ));
end if;
end if;
- return Add_Loop_Actions (L);
+ return Add_Loop_Actions (Stmts);
end Gen_Assign;
--------------
