A multi-level selected component can designate a call to a parameterless
protected operation whose target object is itself given by a selected component.
When the node is rewritten as a function call, it is necessary to preserve the
tree structure of the name, so that overload information and subsequent action
insertions work properly.
THe following must compile quietly:
gcc -c ia-ib-ic-d.adb
---
WITH Ada.Unchecked_Deallocation;
PACKAGE BODY ia.ib.ic.d IS
-- ------------------------------------------------------------------------
-- Protected declaration
-- ------------------------------------------------------------------------
PROTECTED TYPE network_state_controller IS
PROCEDURE set_send_success (success : IN Boolean);
PROCEDURE set_receive_success (success : IN Boolean);
PROCEDURE set_connected;
PROCEDURE set_disconnected;
PROCEDURE set_open_connection;
PROCEDURE set_close_connection;
FUNCTION is_connected RETURN Boolean;
FUNCTION is_opened RETURN Boolean;
ENTRY wait_disconnected;
ENTRY wait_connected;
PRIVATE
connected : Boolean := False;
open_connection : Boolean := False;
send_success : Boolean := True;
receive_success : Boolean := True;
END network_state_controller;
TYPE internals IS RECORD
-- object management
-- -----------------
is_initialized : Boolean := False;
-- Network
-- -------
network_state : network_state_controller;
-- values that may be sent to the gun
-- ----------------------------------
-- values reported back by the gun
-- -------------------------------
-- raw telegram buffers
-- --------------------
-- comms house keeping and control
-- -------------------------------
-- fire zone comms
-- ---------------
fire_zone_request_timeout : Natural := 0; -- 10 ms cycle count
fire_zone_request_started_at : Natural := 0;-- 10 ms cycle count
-- Trace
-- -----
use_tracer_position_entry : Boolean := False;
tracer_dusc : Boolean := False;
tracer_dusc_overwrite : Boolean := False;
tracer_zoom_overwrite : Boolean := False;
print_counter : Positive := 1; -- for debugging information
call_counter : Natural := 0;
tick_cycle : Natural := 0;
proceed_counter : Natural := 0; -- for test purpose
self : reference := NULL;
trace_alarm : Boolean := False;
trace_fire : Boolean := False;
END RECORD;
FUNCTION create RETURN reference IS
ref : reference := NEW object;
BEGIN
ref.hidden := NEW internals;
ref.hidden.self := ref;
RETURN ref;
EXCEPTION
WHEN error : OTHERS =>
RETURN NULL;
END create;
PROCEDURE initialize (obj : IN OUT object; success : OUT Boolean) IS
BEGIN
IF NOT obj.hidden.is_initialized THEN
obj.hidden.is_initialized := True;
success := True;
END IF;
EXCEPTION
WHEN error : OTHERS =>
success := False;
END initialize;
-- ------------------------------------------------------------------------
PROCEDURE free IS NEW Ada.Unchecked_Deallocation (object'class, reference);
PROCEDURE free IS NEW Ada.Unchecked_Deallocation
(internals,
access_internals);
-- ------------------------------------------------------------------------
PROCEDURE finalize (obj : IN OUT reference) IS
BEGIN
IF obj /= NULL THEN
IF obj.hidden /= NULL THEN
free (obj.hidden);
END IF;
free (obj);
END IF;
EXCEPTION
WHEN error : OTHERS =>
NULL;
END finalize;
FUNCTION is_connected (obj : IN object) RETURN Boolean IS
BEGIN
IF obj.hidden.network_state.is_opened
AND THEN obj.hidden.network_state.is_connected THEN
RETURN True;
ELSE
RETURN False;
END IF;
EXCEPTION
WHEN error : OTHERS =>
RETURN False;
END is_connected;
max_before_reconnect : CONSTANT Positive := 100;
PROTECTED BODY network_state_controller IS
PROCEDURE set_send_success (success : IN Boolean) IS
BEGIN
send_success := success;
END set_send_success;
PROCEDURE set_receive_success (success : IN Boolean) IS
BEGIN
receive_success := success;
END set_receive_success;
PROCEDURE set_connected IS
BEGIN
connected := True;
END set_connected;
PROCEDURE set_disconnected IS
BEGIN
connected := False;
END set_disconnected;
FUNCTION is_connected RETURN Boolean IS
BEGIN
RETURN open_connection AND THEN connected;
END is_connected;
FUNCTION is_opened RETURN Boolean IS
BEGIN
RETURN open_connection;
END is_opened;
PROCEDURE set_close_connection IS
BEGIN
connected := False;
open_connection := False;
END set_close_connection;
PROCEDURE set_open_connection IS
BEGIN
connected := False;
open_connection := True;
END set_open_connection;
ENTRY wait_disconnected WHEN NOT connected IS
BEGIN
NULL;
END wait_disconnected;
ENTRY wait_connected WHEN open_connection AND THEN connected IS
BEGIN
NULL;
END wait_connected;
END network_state_controller;
END ia.ib.ic.d;
---
PACKAGE ia.ib.ic.d IS
TYPE object IS NEW ia.ib.ic.object WITH PRIVATE;
TYPE reference IS ACCESS ALL object'class;
FUNCTION create RETURN reference;
PROCEDURE initialize (obj : IN OUT object; success : OUT Boolean);
PROCEDURE finalize (obj : IN OUT reference);
FUNCTION is_connected (obj : IN object) RETURN Boolean;
PRIVATE
TYPE internals;
TYPE access_internals IS ACCESS ALL internals;
TYPE object IS NEW ia.ib.ic.object WITH RECORD
hidden : access_internals := NULL;
END RECORD;
END ia.ib.ic.d;
---
PACKAGE ia.ib.ic IS
TYPE object IS NEW ia.ib.object WITH PRIVATE;
TYPE reference IS ACCESS ALL object'class;
PRIVATE
TYPE object IS NEW ia.ib.object WITH NULL RECORD;
END ia.ib.ic;
---
PACKAGE ia.ib IS
TYPE object IS NEW ia.object WITH PRIVATE;
TYPE reference IS ACCESS ALL object'class;
PRIVATE
TYPE object IS NEW ia.object WITH NULL RECORD;
END ia.ib;
---
PACKAGE ia IS
TYPE object IS ABSTRACT TAGGED PRIVATE;
TYPE reference IS ACCESS ALL ia.object'class;
TYPE view IS ACCESS CONSTANT ia.object'class;
nil : CONSTANT view := NULL;
PROCEDURE finalize (obj : ACCESS object'class) IS ABSTRACT;
PRIVATE
TYPE object IS ABSTRACT TAGGED NULL RECORD;
END ia;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-08-01 Ed Schonberg <schonb...@adacore.com>
* sem_res.adb (Check_Parameterless_Call): Use Relocate_Node
to create the name of the parameterless call, rather than
New_Copy, to preserve the tree structure when the name is a
complex expression, e.g. a selected component that denotes a
protected operation, whose prefix is itself a selected component.
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 213451)
+++ sem_res.adb (working copy)
@@ -1102,8 +1102,11 @@
end if;
end if;
- Nam := New_Copy (N);
+ -- The node is the name of the parameterless call. Preserve its
+ -- descendants, which may be complex expressions.
+ Nam := Relocate_Node (N);
+
-- If overloaded, overload set belongs to new copy
Save_Interps (N, Nam);
