Raise PE on potentially-blocking operation in PO.

  * common/a-retide.adb (Delay_Until): raise PE if within a PO.
  * common/s-taprob.adb: updated comments to note that this is a
      restricted profile, so Detect_Blocking can be assumed, even absent
      the pragma.
  * test-stm32f4/delay_in_po-main.adb, test-stm32f4/delay_in_po.adb,
    test-stm32f4/delay_in_po.ads: demonstrate that blocking is detected.
  * test-stm32f4/testbed.gpr: add delay_in_po test.

common/a-retide.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---    Copyright (C) 1992-2010, 2016-2018, Free Software Foundation, Inc.    --
+--  Copyright (C) 1992-2010, 2016-2018, 2020 Free Software Foundation, Inc. --
 --                                                                          --
 -- GNARL 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- --
@@ -32,6 +32,7 @@
 --  Modified from GCC 4.9.1 for Cortex GNAT RTS.
 
 with Interfaces;
+with System.Tasking;
 
 package body Ada.Real_Time.Delays is
 
@@ -43,7 +44,15 @@ package body Ada.Real_Time.Delays is
         External_Name => "vTaskDelay";
       Now : constant Time := Clock;
       Ticks_To_Delay : constant Time := (if T > Now then T - Now else 0);
+      Self_Id : constant System.Tasking.Task_Id := System.Tasking.Self;
    begin
+      --  This is a restricted profile, so we must raise Program_Error
+      --  if this potentially blocking operation is called from a
+      --  protected action.
+      if Self_Id.Common.Protected_Action_Nesting > 0 then
+         raise Program_Error with "potentially blocking operation";
+      end if;
+
       vTaskDelay (Interfaces.Unsigned_32 (Ticks_To_Delay));
    end Delay_Until;
 

common/s-taprob.adb

@@ -110,13 +110,14 @@ package body System.Tasking.Protected_Objects is
          declare
             Self_Id : constant Task_Id := Self;
          begin
-            --  If pragma Detect_Blocking is active then, as described
-            --  in the ARM 9.5.1, par. 15, we must check whether this
-            --  is an external call on a protected subprogram with the
-            --  same target object as that of the protected action
-            --  that is currently in progress (i.e., if the caller is
-            --  already the protected object's owner). If this is the
-            --  case Program_Error must be raised.
+            --  If pragma Detect_Blocking is active (which it is, this
+            --  is a restricted profile) then, as described in the ARM
+            --  9.5.1, par. 15, we must check whether this is an
+            --  external call on a protected subprogram with the same
+            --  target object as that of the protected action that is
+            --  currently in progress (i.e., if the caller is already
+            --  the protected object's owner). If this is the case
+            --  Program_Error must be raised.
             if Object.Owner = Self_Id then
                raise Program_Error with "external call on same object";
             end if;
@@ -130,6 +131,10 @@ package body System.Tasking.Protected_Objects is
             --  We are entering in a protected action, so that we
             --  increase the protected object nesting level and update
             --  the protected object's owner.
+            --
+            --  In the non-restricted RTS, this is only done if pragma
+            --  Detect_Blocking is active, but this is a restricted
+            --  profile, so no need to check.
 
             --  Update the protected object's owner
             Object.Owner := Self_Id;
@@ -159,13 +164,14 @@ package body System.Tasking.Protected_Objects is
          declare
             Self_Id : constant Task_Id := Self;
          begin
-            --  If pragma Detect_Blocking is active then, as described
-            --  in the ARM 9.5.1, par. 15, we must check whether this
-            --  is an external call on protected subprogram with the
-            --  same target object as that of the protected action
-            --  that is currently in progress (i.e., if the caller is
-            --  already the protected object's owner). If this is the
-            --  case hence Program_Error must be raised.
+            --  If pragma Detect_Blocking is active (which it is, this
+            --  is a restricted profile) then, as described in the ARM
+            --  9.5.1, par. 15, we must check whether this is an
+            --  external call on protected subprogram with the same
+            --  target object as that of the protected action that is
+            --  currently in progress (i.e., if the caller is already
+            --  the protected object's owner). If this is the case
+            --  hence Program_Error must be raised.
             --
             --  Note that in this case (getting read access), several
             --  tasks may have read ownership of the protected object,
@@ -190,6 +196,10 @@ package body System.Tasking.Protected_Objects is
 
             --  We are entering in a protected action, so we increase
             --  the protected object nesting level.
+            --
+            --  In the non-restricted RTS, this is only done if pragma
+            --  Detect_Blocking is active, but this is a restricted
+            --  profile, so no need to check.
 
             --  Update the protected object's owner
             Object.Owner := Self_Id;

test-stm32f4/delay_in_po-main.adb

@@ -0,0 +1,13 @@
+--  Copyright (C) 2020 Free Software Foundation, Inc.
+
+--  This file is part of the Cortex GNAT RTS package.
+--
+--  Copying and distribution of this file, with or without
+--  modification, are permitted in any medium without royalty provided
+--  the copyright notice and this notice are preserved.  This file is
+--  offered as-is, without any warranty.
+
+procedure Delay_In_PO.Main is
+begin
+   PO.Potentially_Blocking;
+end Delay_In_PO.Main;

test-stm32f4/delay_in_po.adb

@@ -0,0 +1,23 @@
+--  Copyright (C) 2020 Free Software Foundation, Inc.
+
+--  This file is part of the Cortex GNAT RTS package.
+--
+--  Copying and distribution of this file, with or without
+--  modification, are permitted in any medium without royalty provided
+--  the copyright notice and this notice are preserved.  This file is
+--  offered as-is, without any warranty.
+
+with Ada.Real_Time;
+
+package body Delay_In_PO is
+
+   protected body PO is
+
+      procedure Potentially_Blocking is
+      begin
+         delay until Ada.Real_Time.Time_Last;
+      end Potentially_Blocking;
+
+   end PO;
+
+end Delay_In_PO;

test-stm32f4/delay_in_po.ads

@@ -0,0 +1,19 @@
+--  Copyright (C) 2020 Free Software Foundation, Inc.
+
+--  This file is part of the Cortex GNAT RTS package.
+--
+--  Copying and distribution of this file, with or without
+--  modification, are permitted in any medium without royalty provided
+--  the copyright notice and this notice are preserved.  This file is
+--  offered as-is, without any warranty.
+
+--  The purpose of this little suite is to provoke Program_Error by a
+--  'delay until' inside a protected object.
+
+package Delay_In_PO is
+
+   protected PO is
+      procedure Potentially_Blocking;
+   end PO;
+
+end Delay_In_PO;

test-stm32f4/testbed.gpr

@@ -1,4 +1,4 @@
---  Copyright (C) 2016-2018 Free Software Foundation, Inc.
+--  Copyright (C) 2016-2020 Free Software Foundation, Inc.
 --
 --  This file is part of the Cortex GNAT RTS package.
 --
@@ -18,7 +18,9 @@
 
 project Testbed is
 
-   for Main use ("testbed.adb", "generate_hard_fault.adb");
+   for Main use ("testbed.adb",
+                 "delay_in_po-main.adb",
+                 "generate_hard_fault.adb");
    for Languages use ("Ada", "C");
    for Source_Dirs use (".", "../test-common");
    for Object_Dir use ".build";
@@ -27,6 +29,7 @@ project Testbed is
    for Runtime ("ada") use project'Project_Dir & "../local/stm32f4";
 
    package Builder is
+      for Executable ("delay_in_po-main.adb") use "delay_in_po";
       for Global_Configuration_Pragmas use "gnat.adc";
       for Global_Compilation_Switches ("ada") use
         (