[Ada] Parameterless calls to protected operations on selected components.

[Arnaud Charlet]

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  <schonberg@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.

-------------- next part --------------
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);