[PATCH v2 04/10] Introduce strub: tests for C++ and Ada

[Alexandre Oliva <oliva@adacore.com>]

for  gcc/testsuite/ChangeLog

	* g++.dg/strub-run1.C: New.
	* g++.dg/torture/strub-init1.C: New.
	* g++.dg/torture/strub-init2.C: New.
	* g++.dg/torture/strub-init3.C: New.
	* gnat.dg/strub_attr.adb, gnat.dg/strub_attr.ads: New.
	* gnat.dg/strub_ind.adb, gnat.dg/strub_ind.ads: New.

diff --git a/gcc/testsuite/g++.dg/strub-run1.C b/gcc/testsuite/g++.dg/strub-run1.C
new file mode 100644
index 0000000000000..0d367fb83d09d
--- /dev/null
+++ b/gcc/testsuite/g++.dg/strub-run1.C
@@ -0,0 +1,19 @@
+// { dg-do run }
+// { dg-options "-fstrub=internal" }
+
+// Check that we don't get extra copies.
+
+struct T {
+  T &self;
+  void check () const { if (&self != this) __builtin_abort (); }
+  T() : self (*this) { check (); }
+  T(const T& ck) : self (*this) { ck.check (); check (); }
+  ~T() { check (); }
+};
+
+T foo (T q) { q.check (); return T(); }
+T bar (T p) { p.check (); return foo (p); }
+
+int main () {
+  bar (T()).check ();
+}
diff --git a/gcc/testsuite/g++.dg/torture/strub-init1.C b/gcc/testsuite/g++.dg/torture/strub-init1.C
new file mode 100644
index 0000000000000..c226ab10ff651
--- /dev/null
+++ b/gcc/testsuite/g++.dg/torture/strub-init1.C
@@ -0,0 +1,13 @@
+/* { dg-do compile } */
+/* { dg-options "-fstrub=strict -fdump-ipa-strub" } */
+
+extern int __attribute__((__strub__)) initializer ();
+
+int f() {
+  static int x = initializer ();
+  return x;
+}
+
+/* { dg-final { scan-ipa-dump "strub_enter" "strub" } } */
+/* { dg-final { scan-ipa-dump "strub_leave" "strub" } } */
+/* { dg-final { scan-ipa-dump-not "strub_update" "strub" } } */
diff --git a/gcc/testsuite/g++.dg/torture/strub-init2.C b/gcc/testsuite/g++.dg/torture/strub-init2.C
new file mode 100644
index 0000000000000..a7911f1fa7212
--- /dev/null
+++ b/gcc/testsuite/g++.dg/torture/strub-init2.C
@@ -0,0 +1,14 @@
+/* { dg-do compile } */
+/* { dg-options "-fstrub=strict -fdump-ipa-strub" } */
+
+extern int __attribute__((__strub__)) initializer ();
+
+static int x = initializer ();
+
+int f() {
+  return x;
+}
+
+/* { dg-final { scan-ipa-dump "strub_enter" "strub" } } */
+/* { dg-final { scan-ipa-dump "strub_leave" "strub" } } */
+/* { dg-final { scan-ipa-dump-not "strub_update" "strub" } } */
diff --git a/gcc/testsuite/g++.dg/torture/strub-init3.C b/gcc/testsuite/g++.dg/torture/strub-init3.C
new file mode 100644
index 0000000000000..6ebebcd01e8ea
--- /dev/null
+++ b/gcc/testsuite/g++.dg/torture/strub-init3.C
@@ -0,0 +1,13 @@
+/* { dg-do compile } */
+/* { dg-options "-fstrub=strict -fdump-ipa-strub" } */
+
+extern int __attribute__((__strub__)) initializer ();
+
+int f() {
+  int x = initializer ();
+  return x;
+}
+
+/* { dg-final { scan-ipa-dump "strub_enter" "strub" } } */
+/* { dg-final { scan-ipa-dump "strub_leave" "strub" } } */
+/* { dg-final { scan-ipa-dump-not "strub_update" "strub" } } */
diff --git a/gcc/testsuite/gnat.dg/strub_access.adb b/gcc/testsuite/gnat.dg/strub_access.adb
new file mode 100644
index 0000000000000..29e6996ecf61c
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_access.adb
@@ -0,0 +1,21 @@
+--  { dg-do compile }
+--  { dg-options "-fstrub=relaxed -fdump-ipa-strubm" }
+
+--  The main subprogram doesn't read from the automatic variable, but
+--  being an automatic variable, its presence should be enough for the
+--  procedure to get strub enabled.
+
+procedure Strub_Access is
+   type Strub_Int is new Integer;
+   pragma Machine_Attribute (Strub_Int, "strub");
+   
+   X : aliased Strub_Int := 0;
+
+   function F (P : access Strub_Int) return Strub_Int is (P.all);
+
+begin
+   X := F (X'Access);
+end Strub_Access;
+
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]internal\[)\]\[)\]" 1 "strubm" } }
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls-opt\[)\]\[)\]" 1 "strubm" } }
diff --git a/gcc/testsuite/gnat.dg/strub_access1.adb b/gcc/testsuite/gnat.dg/strub_access1.adb
new file mode 100644
index 0000000000000..dae4706016436
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_access1.adb
@@ -0,0 +1,16 @@
+--  { dg-do compile }
+--  { dg-options "-fstrub=relaxed" }
+
+--  Check that we reject 'Access of a strub variable whose type does
+--  not carry a strub modifier.
+
+procedure Strub_Access1 is
+   X : aliased Integer := 0;
+   pragma Machine_Attribute (X, "strub");
+
+   function F (P : access Integer) return Integer is (P.all);
+   
+begin
+   X := F (X'Unchecked_access); -- OK.
+   X := F (X'Access); -- { dg-error "target access type drops .strub. mode" }
+end Strub_Access1;
diff --git a/gcc/testsuite/gnat.dg/strub_attr.adb b/gcc/testsuite/gnat.dg/strub_attr.adb
new file mode 100644
index 0000000000000..10445d7cf8451
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_attr.adb
@@ -0,0 +1,37 @@
+--  { dg-do compile }
+--  { dg-options "-fstrub=strict -fdump-ipa-strubm -fdump-ipa-strub" }
+
+package body Strub_Attr is
+   E : exception;
+
+   procedure P (X : Integer) is
+   begin
+      raise E;
+   end;
+   
+   function F (X : Integer) return Integer is
+   begin
+      return X * X;
+   end;
+   
+   function G return Integer is (F (X));
+   --  function G return Integer is (FP (X));
+   --  Calling G would likely raise an exception, because although FP
+   --  carries the strub at-calls attribute needed to call F, the
+   --  attribute is dropped from the type used for the call proper.
+end Strub_Attr;
+
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]internal\[)\]\[)\]" 2 "strubm" } }
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls\[)\]\[)\]" 0 "strubm" } }
+--  { dg-final { scan-ipa-dump-times "\[(\]strub\[)\]" 1 "strubm" } }
+
+--  { dg-final { scan-ipa-dump-times "strub.watermark_ptr" 6 "strub" } }
+--  We have 1 at-calls subprogram (F) and 2 wrapped (P and G).
+--  For each of them, there's one match for the wrapped signature, 
+--  and one for the update call.
+
+--  { dg-final { scan-ipa-dump-times "strub.watermark" 27 "strub" } }
+--  The 6 matches above, plus:
+--  5*2: wm var decl, enter, call, leave and clobber for each wrapper;
+--  2*1: an extra leave and clobber for the exception paths in the wrappers.
+--  7*1: for the F call in G, including EH path.
diff --git a/gcc/testsuite/gnat.dg/strub_attr.ads b/gcc/testsuite/gnat.dg/strub_attr.ads
new file mode 100644
index 0000000000000..a94c23bf41833
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_attr.ads
@@ -0,0 +1,12 @@
+package Strub_Attr is
+   procedure P (X : Integer);
+   pragma Machine_Attribute (P, "strub", "internal");
+
+   function F (X : Integer) return Integer;
+   pragma Machine_Attribute (F, "strub");
+
+   X : Integer := 0;
+   pragma Machine_Attribute (X, "strub");
+
+   function G return Integer;
+end Strub_Attr;
diff --git a/gcc/testsuite/gnat.dg/strub_disp.adb b/gcc/testsuite/gnat.dg/strub_disp.adb
new file mode 100644
index 0000000000000..3dbcc4a357cba
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_disp.adb
@@ -0,0 +1,64 @@
+--  { dg-do compile }
+
+procedure Strub_Disp is
+   package Foo is
+      type A is tagged null record;
+
+      procedure P (I : Integer; X : A);
+      pragma Machine_Attribute (P, "strub", "at-calls");
+      
+      function F (X : access A) return Integer;
+
+      type B is new A with null record;
+      
+      overriding
+      procedure P (I : Integer; X : B); -- { dg-error "requires the same .strub. mode" }
+
+      overriding
+      function F (X : access B) return Integer;
+      pragma Machine_Attribute (F, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" }
+
+   end Foo;
+
+   package body Foo is
+      procedure P (I : Integer; X : A) is
+      begin
+	 null;
+      end;
+      
+      function F (X : access A) return Integer is (0);
+
+      overriding
+      procedure P (I : Integer; X : B) is
+      begin
+	 P (I, A (X));
+      end;
+      
+      overriding
+      function F (X : access B) return Integer is (1);
+   end Foo;
+
+   use Foo;
+
+   procedure Q (X : A'Class) is
+   begin
+      P (-1, X);
+   end;
+
+   XA : aliased A;
+   XB : aliased B;
+   I : Integer := 0;
+   XC : access A'Class;
+begin
+   Q (XA);
+   Q (XB);
+   
+   I := I + F (XA'Access);
+   I := I + F (XB'Access);
+
+   XC := XA'Access;
+   I := I + F (XC);
+
+   XC := XB'Access;
+   I := I + F (XC);
+end Strub_Disp;
diff --git a/gcc/testsuite/gnat.dg/strub_disp1.adb b/gcc/testsuite/gnat.dg/strub_disp1.adb
new file mode 100644
index 0000000000000..09756a74b7d81
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_disp1.adb
@@ -0,0 +1,79 @@
+--  { dg-do compile }
+--  { dg-options "-fdump-ipa-strub" }
+
+-- Check that at-calls dispatching calls are transformed.
+
+procedure Strub_Disp1 is
+   package Foo is
+      type A is tagged null record;
+
+      procedure P (I : Integer; X : A);
+      pragma Machine_Attribute (P, "strub", "at-calls");
+      
+      function F (X : access A) return Integer;
+      pragma Machine_Attribute (F, "strub", "at-calls");
+
+      type B is new A with null record;
+      
+      overriding
+      procedure P (I : Integer; X : B);
+      pragma Machine_Attribute (P, "strub", "at-calls");
+
+      overriding
+      function F (X : access B) return Integer;
+      pragma Machine_Attribute (F, "strub", "at-calls");
+
+   end Foo;
+
+   package body Foo is
+      procedure P (I : Integer; X : A) is
+      begin
+	 null;
+      end;
+      
+      function F (X : access A) return Integer is (0);
+
+      overriding
+      procedure P (I : Integer; X : B) is
+      begin
+	 P (I, A (X)); -- strub-at-calls non-dispatching call
+      end;
+      
+      overriding
+      function F (X : access B) return Integer is (1);
+   end Foo;
+
+   use Foo;
+
+   procedure Q (X : A'Class) is
+   begin
+      P (-1, X); -- strub-at-calls dispatching call.
+   end;
+
+   XA : aliased A;
+   XB : aliased B;
+   I : Integer := 0;
+   XC : access A'Class;
+begin
+   Q (XA);
+   Q (XB);
+   
+   I := I + F (XA'Access); -- strub-at-calls non-dispatching call
+   I := I + F (XB'Access); -- strub-at-calls non-dispatching call
+
+   XC := XA'Access;
+   I := I + F (XC); -- strub-at-calls dispatching call.
+
+   XC := XB'Access;
+   I := I + F (XC); -- strub-at-calls dispatching call.
+end Strub_Disp1;
+
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls\[)\]\[)\]" 4 "strub" } }
+
+--  Count the strub-at-calls non-dispatching calls 
+--  (+ 2 each, for the matching prototypes)
+--  { dg-final { scan-ipa-dump-times "foo\.p \[(\]\[^\n\]*watermark" 3 "strub" } }
+--  { dg-final { scan-ipa-dump-times "foo\.f \[(\]\[^\n\]*watermark" 4 "strub" } }
+
+--  Count the strub-at-calls dispatching calls.
+--  { dg-final { scan-ipa-dump-times "_\[0-9\]* \[(\]\[^\n\]*watermark" 3 "strub" } }
diff --git a/gcc/testsuite/gnat.dg/strub_ind.adb b/gcc/testsuite/gnat.dg/strub_ind.adb
new file mode 100644
index 0000000000000..da56acaa957d2
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_ind.adb
@@ -0,0 +1,33 @@
+--  { dg-do compile }
+--  { dg-options "-fstrub=strict" }
+
+--  This is essentially the same test as strub_attr.adb, 
+--  but applying attributes to access types as well.
+--  That doesn't quite work yet, so we get an error we shouldn't get.
+
+package body Strub_Ind is
+   E : exception;
+
+   function G return Integer;
+
+   procedure P (X : Integer) is
+   begin
+      raise E;
+   end;
+   
+   function F (X : Integer) return Integer is
+   begin
+      return X * X;
+   end;
+   
+   function G return Integer is (FP (X));
+
+   type GT is access function return Integer;
+
+   type GT_SAC is access function return Integer;
+   pragma Machine_Attribute (GT_SAC, "strub", "at-calls");
+
+   GP : GT_SAC := GT_SAC (GT'(G'Access)); -- { dg-error "incompatible" }
+   -- pragma Machine_Attribute (GP, "strub", "at-calls");
+
+end Strub_Ind;
diff --git a/gcc/testsuite/gnat.dg/strub_ind.ads b/gcc/testsuite/gnat.dg/strub_ind.ads
new file mode 100644
index 0000000000000..99a65fc24b1ec
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_ind.ads
@@ -0,0 +1,17 @@
+package Strub_Ind is
+   procedure P (X : Integer);
+   pragma Machine_Attribute (P, "strub", "internal");
+
+   function F (X : Integer) return Integer;
+   pragma Machine_Attribute (F, "strub");
+
+   X : Integer := 0;
+   pragma Machine_Attribute (X, "strub");
+
+   type FT is access function (X : Integer) return Integer;
+   pragma Machine_Attribute (FT, "strub", "at-calls");
+
+   FP : FT := F'Access;
+   -- pragma Machine_Attribute (FP, "strub", "at-calls"); -- not needed
+
+end Strub_Ind;
diff --git a/gcc/testsuite/gnat.dg/strub_ind1.adb b/gcc/testsuite/gnat.dg/strub_ind1.adb
new file mode 100644
index 0000000000000..825e395e6819c
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_ind1.adb
@@ -0,0 +1,41 @@
+--  { dg-do compile }
+--  { dg-options "-fstrub=strict -fdump-ipa-strubm" }
+
+--  This is essentially the same test as strub_attr.adb, 
+--  but with an explicit conversion.
+
+package body Strub_Ind1 is
+   E : exception;
+
+   type Strub_Int is New Integer;
+   pragma Machine_Attribute (Strub_Int, "strub");
+
+   function G return Integer;
+   pragma Machine_Attribute (G, "strub", "disabled");
+
+   procedure P (X : Integer) is
+   begin
+      raise E;
+   end;
+   
+   function G return Integer is (FP (X));
+
+   type GT is access function return Integer;
+   pragma Machine_Attribute (GT, "strub", "disabled");
+
+   type GT_SC is access function return Integer;
+   pragma Machine_Attribute (GT_SC, "strub", "callable");
+
+   GP : GT_SC := GT_SC (GT'(G'Access));
+   --  pragma Machine_Attribute (GP, "strub", "callable"); -- not needed.
+
+   function F (X : Integer) return Integer is
+   begin
+      return X * GP.all;
+   end;
+   
+end Strub_Ind1;
+
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]disabled\[)\]\[)\]" 1 "strubm" } }
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]internal\[)\]\[)\]" 1 "strubm" } }
+--  { dg-final { scan-ipa-dump-times "\[(\]strub\[)\]" 1 "strubm" } }
diff --git a/gcc/testsuite/gnat.dg/strub_ind1.ads b/gcc/testsuite/gnat.dg/strub_ind1.ads
new file mode 100644
index 0000000000000..d3f1273b3a6b9
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_ind1.ads
@@ -0,0 +1,17 @@
+package Strub_Ind1 is
+   procedure P (X : Integer);
+   pragma Machine_Attribute (P, "strub", "internal");
+
+   function F (X : Integer) return Integer;
+   pragma Machine_Attribute (F, "strub");
+
+   X : aliased Integer := 0;
+   pragma Machine_Attribute (X, "strub");
+
+   type FT is access function (X : Integer) return Integer;
+   pragma Machine_Attribute (FT, "strub", "at-calls");
+
+   FP : FT := F'Access;
+   pragma Machine_Attribute (FP, "strub", "at-calls");
+
+end Strub_Ind1;
diff --git a/gcc/testsuite/gnat.dg/strub_ind2.adb b/gcc/testsuite/gnat.dg/strub_ind2.adb
new file mode 100644
index 0000000000000..e918b39263117
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_ind2.adb
@@ -0,0 +1,34 @@
+--  { dg-do compile }
+--  { dg-options "-fstrub=strict" }
+
+--  This is essentially the same test as strub_attr.adb, 
+--  but with an explicit conversion.
+
+package body Strub_Ind2 is
+   E : exception;
+
+   function G return Integer;
+   pragma Machine_Attribute (G, "strub", "callable");
+
+   procedure P (X : Integer) is
+   begin
+      raise E;
+   end;
+   
+   function G return Integer is (FP (X));
+
+   type GT is access function return Integer;
+   pragma Machine_Attribute (GT, "strub", "callable");
+
+   type GT_SD is access function return Integer;
+   pragma Machine_Attribute (GT_SD, "strub", "disabled");
+
+   GP : GT_SD := GT_SD (GT'(G'Access));
+   --  pragma Machine_Attribute (GP, "strub", "disabled"); -- not needed.
+
+   function F (X : Integer) return Integer is
+   begin
+      return X * GP.all; --  { dg-error "using non-.strub. type" }
+   end;
+   
+end Strub_Ind2;
diff --git a/gcc/testsuite/gnat.dg/strub_ind2.ads b/gcc/testsuite/gnat.dg/strub_ind2.ads
new file mode 100644
index 0000000000000..e13865ec49c38
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_ind2.ads
@@ -0,0 +1,17 @@
+package Strub_Ind2 is
+   procedure P (X : Integer);
+   pragma Machine_Attribute (P, "strub", "internal");
+
+   function F (X : Integer) return Integer;
+   pragma Machine_Attribute (F, "strub");
+
+   X : Integer := 0;
+   pragma Machine_Attribute (X, "strub");
+
+   type FT is access function (X : Integer) return Integer;
+   pragma Machine_Attribute (FT, "strub", "at-calls");
+
+   FP : FT := F'Access;
+   pragma Machine_Attribute (FP, "strub", "at-calls");
+
+end Strub_Ind2;
diff --git a/gcc/testsuite/gnat.dg/strub_intf.adb b/gcc/testsuite/gnat.dg/strub_intf.adb
new file mode 100644
index 0000000000000..728b85572b719
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_intf.adb
@@ -0,0 +1,93 @@
+--  { dg-do compile }
+
+--  Check that strub mode mismatches between overrider and overridden
+--  subprograms are reported.
+
+procedure Strub_Intf is
+   package Foo is
+      type TP is interface;
+      procedure P (I : Integer; X : TP) is abstract;
+      pragma Machine_Attribute (P, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" }
+
+      type TF is interface;
+      function F (X : access TF) return Integer is abstract;
+
+      type TX is interface;
+      procedure P (I : Integer; X : TX) is abstract;
+
+      type TI is interface and TP and TF and TX;
+      --  When we freeze TI, we detect the mismatch between the
+      --  inherited P and another parent's P.  Because TP appears
+      --  before TX, we inherit P from TP, and report the mismatch at
+      --  the pragma inherited from TP against TX's P.  In contrast,
+      --  when we freeze TII below, since TX appears before TP, we
+      --  report the error at the line in which the inherited
+      --  subprogram is synthesized, namely the line below, against
+      --  the line of the pragma.
+
+      type TII is interface and TX and TP and TF; -- { dg-error "requires the same .strub. mode" }
+
+      function F (X : access TI) return Integer is abstract;
+      pragma Machine_Attribute (F, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" }
+
+      type A is new TI with null record;
+
+      procedure P (I : Integer; X : A);
+      pragma Machine_Attribute (P, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" }
+      
+      function F (X : access A) return Integer; -- { dg-error "requires the same .strub. mode" }
+
+      type B is new TI with null record;
+      
+      overriding
+      procedure P (I : Integer; X : B); -- { dg-error "requires the same .strub. mode" }
+
+      overriding
+      function F (X : access B) return Integer;
+      pragma Machine_Attribute (F, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" }
+
+   end Foo;
+
+   package body Foo is
+      procedure P (I : Integer; X : A) is
+      begin
+	 null;
+      end;
+      
+      function F (X : access A) return Integer is (0);
+
+      overriding
+      procedure P (I : Integer; X : B) is
+      begin
+	 P (I, A (X));
+      end;
+      
+      overriding
+      function F (X : access B) return Integer is (1);
+
+   end Foo;
+
+   use Foo;
+
+   procedure Q (X : TX'Class) is
+   begin
+      P (-1, X);
+   end;
+
+   XA : aliased A;
+   XB : aliased B;
+   I : Integer := 0;
+   XC : access TI'Class;
+begin
+   Q (XA);
+   Q (XB);
+   
+   I := I + F (XA'Access);
+   I := I + F (XB'Access);
+
+   XC := XA'Access;
+   I := I + F (XC);
+
+   XC := XB'Access;
+   I := I + F (XC);
+end Strub_Intf;
diff --git a/gcc/testsuite/gnat.dg/strub_intf1.adb b/gcc/testsuite/gnat.dg/strub_intf1.adb
new file mode 100644
index 0000000000000..aa68fcd2c0b0e
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_intf1.adb
@@ -0,0 +1,86 @@
+--  { dg-do compile }
+--  { dg-options "-fdump-ipa-strub" }
+
+-- Check that at-calls dispatching calls to interfaces are transformed.
+
+procedure Strub_Intf1 is
+   package Foo is
+      type TX is Interface;
+      procedure P (I : Integer; X : TX) is abstract;
+      pragma Machine_Attribute (P, "strub", "at-calls");
+      function F (X : access TX) return Integer is abstract;
+      pragma Machine_Attribute (F, "strub", "at-calls");
+
+      type A is new TX with null record;
+
+      procedure P (I : Integer; X : A);
+      pragma Machine_Attribute (P, "strub", "at-calls");
+      
+      function F (X : access A) return Integer;
+      pragma Machine_Attribute (F, "strub", "at-calls");
+
+      type B is new TX with null record;
+      
+      overriding
+      procedure P (I : Integer; X : B);
+      pragma Machine_Attribute (P, "strub", "at-calls");
+
+      overriding
+      function F (X : access B) return Integer;
+      pragma Machine_Attribute (F, "strub", "at-calls");
+
+   end Foo;
+
+   package body Foo is
+      procedure P (I : Integer; X : A) is
+      begin
+	 null;
+      end;
+      
+      function F (X : access A) return Integer is (0);
+
+      overriding
+      procedure P (I : Integer; X : B) is
+      begin
+	 P (I, A (X));
+      end;
+      
+      overriding
+      function F (X : access B) return Integer is (1);
+
+   end Foo;
+
+   use Foo;
+
+   procedure Q (X : TX'Class) is
+   begin
+      P (-1, X);
+   end;
+
+   XA : aliased A;
+   XB : aliased B;
+   I : Integer := 0;
+   XC : access TX'Class;
+begin
+   Q (XA);
+   Q (XB);
+   
+   I := I + F (XA'Access);
+   I := I + F (XB'Access);
+
+   XC := XA'Access;
+   I := I + F (XC);
+
+   XC := XB'Access;
+   I := I + F (XC);
+end Strub_Intf1;
+
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls\[)\]\[)\]" 4 "strub" } }
+
+--  Count the strub-at-calls non-dispatching calls 
+--  (+ 2 each, for the matching prototypes)
+--  { dg-final { scan-ipa-dump-times "foo\.p \[(\]\[^\n\]*watermark" 3 "strub" } }
+--  { dg-final { scan-ipa-dump-times "foo\.f \[(\]\[^\n\]*watermark" 4 "strub" } }
+
+--  Count the strub-at-calls dispatching calls.
+--  { dg-final { scan-ipa-dump-times "_\[0-9\]* \[(\]\[^\n\]*watermark" 3 "strub" } }
diff --git a/gcc/testsuite/gnat.dg/strub_intf2.adb b/gcc/testsuite/gnat.dg/strub_intf2.adb
new file mode 100644
index 0000000000000..e8880dbc43730
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_intf2.adb
@@ -0,0 +1,55 @@
+--  { dg-do compile }
+
+--  Check that strub mode mismatches between overrider and overridden
+--  subprograms are reported even when the overriders for an
+--  interface's subprograms are inherited from a type that is not a
+--  descendent of the interface.
+
+procedure Strub_Intf2 is
+   package Foo is
+      type A is tagged null record;
+
+      procedure P (I : Integer; X : A);
+      pragma Machine_Attribute (P, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" }
+      
+      function F (X : access A) return Integer;
+
+      type TX is Interface;
+
+      procedure P (I : Integer; X : TX) is abstract; 
+
+      function F (X : access TX) return Integer is abstract;
+      pragma Machine_Attribute (F, "strub", "at-calls");
+
+      type B is new A and TX with null record; -- { dg-error "requires the same .strub. mode" }
+
+   end Foo;
+
+   package body Foo is
+      procedure P (I : Integer; X : A) is
+      begin
+	 null;
+      end;
+      
+      function F (X : access A) return Integer is (0);
+
+   end Foo;
+
+   use Foo;
+
+   procedure Q (X : TX'Class) is
+   begin
+      P (-1, X);
+   end;
+
+   XB : aliased B;
+   I : Integer := 0;
+   XC : access TX'Class;
+begin
+   Q (XB);
+   
+   I := I + F (XB'Access);
+
+   XC := XB'Access;
+   I := I + F (XC);
+end Strub_Intf2;
diff --git a/gcc/testsuite/gnat.dg/strub_renm.adb b/gcc/testsuite/gnat.dg/strub_renm.adb
new file mode 100644
index 0000000000000..217367e712d82
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_renm.adb
@@ -0,0 +1,21 @@
+--  { dg-do compile }
+
+procedure Strub_Renm is
+   procedure P (X : Integer);
+   pragma Machine_Attribute (P, "strub", "at-calls");
+
+   function F return Integer;
+   pragma Machine_Attribute (F, "strub", "internal");
+
+   procedure Q (X : Integer) renames P; -- { dg-error "requires the same .strub. mode" }
+
+   function G return Integer renames F;
+   pragma Machine_Attribute (G, "strub", "callable"); -- { dg-error "requires the same .strub. mode" }
+
+   procedure P (X : Integer) is null;
+   function F return Integer is (0);
+
+begin
+   P (F);
+   Q (G);
+end Strub_Renm;
diff --git a/gcc/testsuite/gnat.dg/strub_renm1.adb b/gcc/testsuite/gnat.dg/strub_renm1.adb
new file mode 100644
index 0000000000000..a11adbfb5a9d6
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_renm1.adb
@@ -0,0 +1,32 @@
+--  { dg-do compile }
+--  { dg-options "-fstrub=relaxed -fdump-ipa-strub" }
+
+procedure Strub_Renm1 is
+   V : Integer := 0;
+   pragma Machine_Attribute (V, "strub");
+
+   procedure P (X : Integer);
+   pragma Machine_Attribute (P, "strub", "at-calls");
+
+   function F return Integer;
+
+   procedure Q (X : Integer) renames P;
+   pragma Machine_Attribute (Q, "strub", "at-calls");
+
+   function G return Integer renames F;
+   pragma Machine_Attribute (G, "strub", "internal");
+
+   procedure P (X : Integer) is null;
+   function F return Integer is (0);
+
+begin
+   P (F);
+   Q (G);
+end Strub_Renm1;
+
+--  This is for P; Q is an alias.
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls\[)\]\[)\]" 1 "strub" } }
+
+--  This is *not* for G, but for Strub_Renm1.
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]wrapped\[)\]\[)\]" 1 "strub" } }
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]wrapper\[)\]\[)\]" 1 "strub" } }
diff --git a/gcc/testsuite/gnat.dg/strub_renm2.adb b/gcc/testsuite/gnat.dg/strub_renm2.adb
new file mode 100644
index 0000000000000..c488c20826fdb
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_renm2.adb
@@ -0,0 +1,32 @@
+--  { dg-do compile }
+--  { dg-options "-fstrub=strict -fdump-ipa-strub" }
+
+procedure Strub_Renm2 is
+   V : Integer := 0;
+   pragma Machine_Attribute (V, "strub");
+
+   procedure P (X : Integer);
+   pragma Machine_Attribute (P, "strub", "at-calls");
+
+   function F return Integer;
+
+   procedure Q (X : Integer) renames P;
+   pragma Machine_Attribute (Q, "strub", "at-calls");
+
+   type T is access function return Integer;
+
+   type TC is access function return Integer;
+   pragma Machine_Attribute (TC, "strub", "callable");
+
+   FCptr : constant TC := TC (T'(F'Access));
+
+   function G return Integer renames FCptr.all;
+   pragma Machine_Attribute (G, "strub", "callable");
+
+   procedure P (X : Integer) is null;
+   function F return Integer is (0);
+
+begin
+   P (F);  -- { dg-error "calling non-.strub." }
+   Q (G);  -- ok, G is callable.
+end Strub_Renm2;
diff --git a/gcc/testsuite/gnat.dg/strub_var.adb b/gcc/testsuite/gnat.dg/strub_var.adb
new file mode 100644
index 0000000000000..3d158de28031f
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_var.adb
@@ -0,0 +1,16 @@
+--  { dg-do compile }
+--  { dg-options "-fstrub=strict -fdump-ipa-strubm" }
+
+-- We don't read from the automatic variable, but being an automatic
+--  variable, its presence should be enough for the procedure to get
+--  strub enabled.
+
+with Strub_Attr;
+procedure Strub_Var is
+   X : Integer := 0;
+   pragma Machine_Attribute (X, "strub");
+begin
+   X := Strub_Attr.F (0);
+end Strub_Var;
+
+--  { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]internal\[)\]\[)\]" 1 "strubm" } }
diff --git a/gcc/testsuite/gnat.dg/strub_var1.adb b/gcc/testsuite/gnat.dg/strub_var1.adb
new file mode 100644
index 0000000000000..6a504e09198b6
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/strub_var1.adb
@@ -0,0 +1,20 @@
+--  { dg-do compile }
+
+with Strub_Attr;
+procedure Strub_Var1 is
+   type TA  -- { dg-warning "does not apply to elements" }
+      is array (1..2) of Integer;
+   pragma Machine_Attribute (TA, "strub");
+   
+   A : TA := (0, 0);  -- { dg-warning "does not apply to elements" }
+   
+   type TR is record  -- { dg-warning "does not apply to fields" }
+      M, N : Integer;
+   end record;
+   pragma Machine_Attribute (TR, "strub");
+   
+   R : TR := (0, 0);
+
+begin
+   A(2) := Strub_Attr.F (A(1));
+end Strub_Var1;

-- 
Alexandre Oliva, happy hacker                https://FSFLA.org/blogs/lxo/
   Free Software Activist                       GNU Toolchain Engineer
Disinformation flourishes because many people care deeply about injustice
but very few check the facts.  Ask me about <https://stallmansupport.org>