C++ Ada derived virtual slots

/* { dg-do compile } */
/* { dg-options "-fdump-ada-spec-slim" } */
/* { dg-final { scan-file derived_virtual_slots_c.ads "procedure Delete \(this : access Derived'Class\)" } } */
/* { dg-final { scan-file derived_virtual_slots_c.ads "procedure Delete_And_Free \(this : access Derived'Class\)" } } */
/* { dg-final { scan-file derived_virtual_slots_c.ads "function Delete_Method \(this : access Base'Class\)" } } */

class Base
{
public:
  Base (int base_value);
  virtual ~Base () = default;
  virtual int inherited_slot () { return base; }
  int Delete () { return base; }
  int base;
  int reserved;
};

class Derived : public Base
{
public:
  Derived (int base_value, int own_value);
  ~Derived () override = default;
  int inherited_slot () override { return base + own; }
  virtual int added_slot () { return base + own + 5; }
  int own;
};

Base::Base (int base_value) : base (base_value), reserved (0) {}
Derived::Derived (int base_value, int own_value)
  : Base (base_value), own (own_value) {}

extern "C" Derived *create_derived () { return new Derived (10, 2); }
extern "C" void delete_derived (Derived *object) { delete object; }
extern "C" int cpp_call_inherited (Derived *object)
{
  return object->inherited_slot ();
}
extern "C" int cpp_call_added (Derived *object) { return object->added_slot (); }

/* { dg-final { cleanup-ada-spec } } */

with Ada.Text_IO;
with Ada.Unchecked_Conversion;
with Derived_Virtual_Slots_C;
with Interfaces.C; use Interfaces.C;

procedure Derived_Virtual_Slots_Consumer is
   package Bindings renames Derived_Virtual_Slots_C;
   type Derived_Access is access all Bindings.Class_Derived.Derived;
   type Derived_Class_Access is
     access all Bindings.Class_Derived.Derived'Class;
   function To_Class is new Ada.Unchecked_Conversion
     (Derived_Access, Derived_Class_Access);

   Object : constant Derived_Access :=
     Derived_Access (Bindings.create_derived);
   View : constant Derived_Class_Access := To_Class (Object);
begin
   if Object = null then
      raise Program_Error with "C++ factory returned null";
   end if;

   Ada.Text_IO.Put_Line ("CHECK Ada inherited slot");
   Ada.Text_IO.Flush (Ada.Text_IO.Standard_Output);
   if Bindings.Class_Derived.inherited_slot (View) /= 12 then
      raise Program_Error with "Ada inherited virtual dispatch differs";
   end if;

   Ada.Text_IO.Put_Line ("CHECK Ada added slot");
   Ada.Text_IO.Flush (Ada.Text_IO.Standard_Output);
   if Bindings.Class_Derived.added_slot (View) /= 17 then
      raise Program_Error with "Ada added virtual dispatch differs";
   end if;

   if Bindings.cpp_call_inherited (Object) /= 12
     or else Bindings.cpp_call_added (Object) /= 17
   then
      raise Program_Error with "C++ virtual dispatch differs";
   end if;

   Bindings.delete_derived (Object);
   Ada.Text_IO.Put_Line ("MATCH derived virtual slots");
end Derived_Virtual_Slots_Consumer;

#!/usr/bin/env bash
set -euo pipefail

if [[ $# -ne 3 ]]; then
  echo "usage: $0 TOOLCHAIN_ROOT GCC_VERSION unpatched|patched" >&2
  exit 2
fi

root=$(cd "$(dirname "${BASH_SOURCE[0]}")/../.." && pwd)
source "$root/scripts/regression-common.sh"
resolve_regression_toolchain "$1"
version=$2
state=$3
[[ "$state" == unpatched || "$state" == patched ]] || exit 2
gxx="$REGRESSION_TOOLCHAIN/bin/g++"
cxx="$root/bundles/cxx-ada-derived-virtual-slots/tests/derived-virtual-slots.C"
ada="$root/bundles/cxx-ada-derived-virtual-slots/tests/derived_virtual_slots_consumer.adb"
work=$(mktemp -d "${TMPDIR:-/tmp}/gnat-cxx-ada-derived-slots.XXXXXX")
trap 'rm -rf "$work"' EXIT

for optimization in 0 2; do
  dir="$work/O$optimization"
  mkdir -p "$dir"
  cp "$cxx" "$ada" "$dir/"
  (
    cd "$dir"
    "${REGRESSION_ENV[@]}" "$gxx" -c "-O$optimization" \
      -fdump-ada-spec-slim derived-virtual-slots.C
    "${REGRESSION_ENV[@]}" "$REGRESSION_GNATMAKE" -q -f \
      "-O$optimization" derived_virtual_slots_consumer.adb \
      -largs derived-virtual-slots.o -lstdc++
  ) >"$dir/build.log" 2>&1 || { cat "$dir/build.log"; exit 1; }

  if [[ "$state" == unpatched ]]; then
    grep -F "procedure Delete_Derived" "$dir/derived_virtual_slots_c.ads"
    set +e
    (cd "$dir"; "${REGRESSION_ENV[@]}" ./derived_virtual_slots_consumer) \
      >"$dir/output.log" 2>&1
    status=$?
    set -e
    [[ $status -ne 0 ]] || {
      echo "error: unpatched derived virtual slot unexpectedly dispatched" >&2
      exit 1
    }
    echo "cxx-ada-derived-virtual-slots -O$optimization: expected bad dispatch (GCC $version)"
  else
    grep -F "procedure Delete (this : access Derived'Class)" "$dir/derived_virtual_slots_c.ads"
    grep -F "procedure Delete_And_Free (this : access Derived'Class)" "$dir/derived_virtual_slots_c.ads"
    grep -F "function Delete_Method (this : access Base'Class)" "$dir/derived_virtual_slots_c.ads"
    (cd "$dir"; "${REGRESSION_ENV[@]}" ./derived_virtual_slots_consumer) \
      >"$dir/output.log" 2>&1 || { cat "$dir/output.log"; exit 1; }
    grep -Fx "MATCH derived virtual slots" "$dir/output.log"
    echo "cxx-ada-derived-virtual-slots -O$optimization: patched (GCC $version)"
  fi
done