restrict.adb (Disallow in No_Run_Time_Mode): Properly specialize the error…

restrict.adb (Disallow in No_Run_Time_Mode): Properly specialize the error message for high integrity mode.

	* restrict.adb (Disallow in No_Run_Time_Mode): Properly specialize
	the error message for high integrity mode.

	* rtsfind.adb (RTE): Give message if we try to find an entity that
	is not available in high integrity mode.

	* rtsfind.ads:
	(OK_To_Use_In_HIE_Mode): New array.
	(RTE): May return Empty in high integrity mode.

	* rtsfind.ads (OK_To_Use_In_No_Run_Time_Mode): New name for
	OK_To_Use_In_HIE_Mode, now includes System_FAT_xxx.

	* sem_ch6.adb (Analyze_Subprogram_Body): Kill body in predefined
	unit if not inlined always and in no runtime mode. Fixes problem
	caused by new Rtsfind changes.

	* sem_ch6.adb (Analyze_Subrogram_Body): Do not Check_References if
	body is deleted.

	* rtsfind.adb (RTE): Make sure we do not try to load unit after
	giving message for entity not available in high integrity mode.

From-SVN: r46214

gcc/ada/ChangeLog

+2001-10-11  Robert Dewar <dewar@gnat.com>
+
+	* restrict.adb (Disallow in No_Run_Time_Mode): Properly specialize 
+	the error message for high integrity mode.
+	
+	* rtsfind.adb (RTE): Give message if we try to find an entity that 
+	is not available in high integrity mode.
+	
+	* rtsfind.ads:
+	(OK_To_Use_In_HIE_Mode): New array.
+	(RTE): May return Empty in high integrity mode.
+	
+	* rtsfind.ads (OK_To_Use_In_No_Run_Time_Mode): New name for 
+	OK_To_Use_In_HIE_Mode, now includes System_FAT_xxx. 
+	
+	* sem_ch6.adb (Analyze_Subprogram_Body): Kill body in predefined 
+	unit if not inlined always and in no runtime mode. Fixes problem 
+	caused by new Rtsfind changes.
+	
+	* sem_ch6.adb (Analyze_Subrogram_Body): Do not Check_References if 
+	body is deleted.
+	
+	* rtsfind.adb (RTE): Make sure we do not try to load unit after 
+	giving message for entity not available in high integrity mode.
+
 2001-10-11  Pascal Obry <obry@gnat.com>
 	
 	* impunit.adb: Add GNAT.CRC32.

gcc/ada/restrict.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.37 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
 --                                                                          --
@@ -37,6 +37,7 @@ with Namet;    use Namet;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
 with Stand;    use Stand;
+with Targparm; use Targparm;
 with Uname;    use Uname;
 
 package body Restrict is
@@ -266,8 +267,13 @@ package body Restrict is
    procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id) is
    begin
       if No_Run_Time then
-         Error_Msg_N
-           ("this construct not allowed in No_Run_Time mode", Enode);
+         if High_Integrity_Mode_On_Target then
+            Error_Msg_N
+              ("this construct not allowed in high integrity mode", Enode);
+         else
+            Error_Msg_N
+              ("this construct not allowed in No_Run_Time mode", Enode);
+         end if;
       end if;
    end Disallow_In_No_Run_Time_Mode;
 

gcc/ada/rtsfind.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.96 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
 --                                                                          --
@@ -26,30 +26,30 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Atree;    use Atree;
-with Casing;   use Casing;
-with Csets;    use Csets;
-with Debug;    use Debug;
-with Einfo;    use Einfo;
-with Elists;   use Elists;
-with Fname;    use Fname;
-with Fname.UF; use Fname.UF;
-with Lib;      use Lib;
-with Lib.Load; use Lib.Load;
-with Namet;    use Namet;
-with Nlists;   use Nlists;
-with Nmake;    use Nmake;
-with Output;   use Output;
-with Opt;      use Opt;
-with Restrict; use Restrict;
-with Sem;      use Sem;
-with Sem_Ch7;  use Sem_Ch7;
-with Sem_Util; use Sem_Util;
-with Sinfo;    use Sinfo;
-with Stand;    use Stand;
-with Snames;   use Snames;
-with Tbuild;   use Tbuild;
-with Uname;    use Uname;
+with Atree;     use Atree;
+with Casing;    use Casing;
+with Csets;     use Csets;
+with Debug;     use Debug;
+with Einfo;     use Einfo;
+with Elists;    use Elists;
+with Fname;     use Fname;
+with Fname.UF;  use Fname.UF;
+with Lib;       use Lib;
+with Lib.Load;  use Lib.Load;
+with Namet;     use Namet;
+with Nlists;    use Nlists;
+with Nmake;     use Nmake;
+with Output;    use Output;
+with Opt;       use Opt;
+with Restrict;  use Restrict;
+with Sem;       use Sem;
+with Sem_Ch7;   use Sem_Ch7;
+with Sem_Util;  use Sem_Util;
+with Sinfo;     use Sinfo;
+with Stand;     use Stand;
+with Snames;    use Snames;
+with Tbuild;    use Tbuild;
+with Uname;     use Uname;
 
 package body Rtsfind is
 
@@ -581,7 +581,6 @@ package body Rtsfind is
       Lib_Unit : Node_Id;
       Pkg_Ent  : Entity_Id;
       Ename    : Name_Id;
-      Enode    : Node_Id;
 
       procedure Check_RPC;
       --  Reject programs that make use of distribution features not supported
@@ -713,6 +712,15 @@ package body Rtsfind is
    --  Start of processing for RTE
 
    begin
+      --  Check violation of no run time mode
+
+      if No_Run_Time
+        and then not OK_To_Use_In_No_Run_Time_Mode (U_Id)
+      then
+         Disallow_In_No_Run_Time_Mode (Current_Error_Node);
+         return Empty;
+      end if;
+
       --  Doing a rtsfind in system.ads is special, as we cannot do this
       --  when compiling System itself. So if we are compiling system then
       --  we should already have acquired and processed the declaration
@@ -731,8 +739,6 @@ package body Rtsfind is
          return Find_Local_Entity (E);
       end if;
 
-      Enode := Current_Error_Node;
-
       --  Load unit if unit not previously loaded
 
       if No (RE_Table (E)) then
@@ -769,10 +775,21 @@ package body Rtsfind is
                Next_Entity (Pkg_Ent);
             end loop;
 
-            --  If we didn't find the unit we want, something is wrong!
+            --  If we didn't find the unit we want, something is wrong
+            --  although in no run time mode, we already gave a suitable
+            --  message, and so we simply return Empty, and the caller must
+            --  be prepared to handle this if the RTE call is otherwise
+            --  possible in high integrity mode.
+
+            if No_Run_Time
+              and then not OK_To_Use_In_No_Run_Time_Mode (U_Id)
+            then
+               return Empty;
 
-            Load_Fail ("entity not in package", U_Id,  RE_Id'Image (E));
-            raise Program_Error;
+            else
+               Load_Fail ("entity not in package", U_Id,  RE_Id'Image (E));
+               raise Program_Error;
+            end if;
          end if;
       end if;
 
@@ -809,7 +826,7 @@ package body Rtsfind is
          end;
       end if;
 
-      --  We can now obtain the entity. Check that the No_Run_Time condition
+      --  We can now obtain the entity. Check that the no run time condition
       --  is not violated. Note that we do not signal the error if we detect
       --  it in a runtime unit. This can only arise if the user explicitly
       --  with'ed the runtime unit (or another runtime unit that uses it
@@ -822,11 +839,12 @@ package body Rtsfind is
 
       if Is_Subprogram (Ent)
         and then not Is_Inlined (Ent)
-        and then Sloc (Enode) /= Standard_Location
+        and then Sloc (Current_Error_Node) /= Standard_Location
         and then not
-          Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Enode)))
+          Is_Predefined_File_Name
+            (Unit_File_Name (Get_Source_Unit (Current_Error_Node)))
       then
-         Disallow_In_No_Run_Time_Mode (Enode);
+         Disallow_In_No_Run_Time_Mode (Current_Error_Node);
       end if;
 
       return Ent;

gcc/ada/rtsfind.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                            $Revision: 1.216 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
 --                                                                          --
@@ -376,6 +376,23 @@ package Rtsfind is
        System_Tasking_Async_Delays_Enqueue_RT;
    --  Range of values for children of System.Tasking.Async_Delays
 
+   OK_To_Use_In_No_Run_Time_Mode : array (RTU_Id) of Boolean :=
+     (Ada_Tags                => True,
+      Interfaces              => True,
+      System                  => True,
+      System_Fat_Flt          => True,
+      System_Fat_LFlt         => True,
+      System_Fat_LLF          => True,
+      System_Fat_SFlt         => True,
+      System_Machine_Code     => True,
+      System_Storage_Elements => True,
+      System_Unsigned_Types   => True,
+      others                  => False);
+   --  This array defines the set of packages that can legitimately be
+   --  accessed by Rtsfind in No_Run_Time mode. Any attempt to load
+   --  any other package in this mode will result in a message noting
+   --  use of a feature not supported in high integrity mode.
+
    --------------------------
    -- Runtime Entity Table --
    --------------------------
@@ -2291,7 +2308,13 @@ package Rtsfind is
    --  expanding) its spec if the unit has not already been loaded. If the
    --  unit cannot be found, or if it does not contain the specified entity,
    --  then an appropriate error message is output ("run-time configuration
-   --  error") and an Unrecoverable_Error exception is raised.
+   --  error") and an Unrecoverable_Error exception is raised. There is one
+   --  situation in which RTE can generate an error message, and that is if
+   --  an unuathorized entity is accessed in high integrity mode. If this
+   --  occurs, the result returned may be Empty, and the caller must deal
+   --  with this possibility if the call to RTE may occur in high integrity
+   --  mode (often this will have been ruled out by specific checks for
+   --  high integrity mode prior to the RTE call).
 
    function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean;
    --  This function determines if the given entity corresponds to the entity

gcc/ada/sem_ch6.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.508 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
 --                                                                          --
@@ -34,6 +34,7 @@ with Elists;   use Elists;
 with Errout;   use Errout;
 with Expander; use Expander;
 with Exp_Ch7;  use Exp_Ch7;
+with Fname;    use Fname;
 with Freeze;   use Freeze;
 with Lib.Xref; use Lib.Xref;
 with Namet;    use Namet;
@@ -816,23 +817,25 @@ package body Sem_Ch6 is
    --  the subprogram, or to perform conformance checks.
 
    procedure Analyze_Subprogram_Body (N : Node_Id) is
+      Loc       : constant Source_Ptr := Sloc (N);
       Body_Spec : constant Node_Id    := Specification (N);
       Body_Id   : Entity_Id           := Defining_Entity (Body_Spec);
       Prev_Id   : constant Entity_Id  := Current_Entity_In_Scope (Body_Id);
 
-      HSS         : Node_Id;
-      Spec_Id     : Entity_Id;
-      Spec_Decl   : Node_Id   := Empty;
-      Last_Formal : Entity_Id := Empty;
-      Conformant  : Boolean;
-      Missing_Ret : Boolean;
+      HSS          : Node_Id;
+      Spec_Id      : Entity_Id;
+      Spec_Decl    : Node_Id   := Empty;
+      Last_Formal  : Entity_Id := Empty;
+      Conformant   : Boolean;
+      Missing_Ret  : Boolean;
+      Body_Deleted : Boolean := False;
 
    begin
       if Debug_Flag_C then
          Write_Str ("====  Compiling subprogram body ");
          Write_Name (Chars (Body_Id));
          Write_Str (" from ");
-         Write_Location (Sloc (N));
+         Write_Location (Loc);
          Write_Eol;
       end if;
 
@@ -922,7 +925,6 @@ package body Sem_Ch6 is
          --  the protected subprogram that will be used in internal calls.
 
          declare
-            Loc      : constant Source_Ptr := Sloc (N);
             Decl     : Node_Id;
             Plist    : List_Id;
             Formal   : Entity_Id;
@@ -1158,7 +1160,40 @@ package body Sem_Ch6 is
          end if;
       end if;
 
-      --  Here we have a real body, not a stub
+      --  Here we have a real body, not a stub. First step is to null out
+      --  the subprogram body if we have the special case of no run time
+      --  mode with a predefined unit, and the subprogram is not marked
+      --  as Inline_Always. The reason is that we should never call such
+      --  a routine in no run time mode, and it may in general have some
+      --  statements that we cannot handle in no run time mode.
+
+      --  ASIS note: we do a replace here, because we are really NOT going
+      --  to analyze the original body and declarations at all, so it is
+      --  useless to keep them around, we really are obliterating the body,
+      --  basically creating a specialized no run time version on the fly
+      --  in which the bodies *are* null.
+
+      if No_Run_Time
+        and then Present (Spec_Id)
+        and then Is_Predefined_File_Name
+                   (Unit_File_Name (Get_Source_Unit (Loc)))
+        and then not Is_Always_Inlined (Spec_Id)
+      then
+         Replace (N,
+           Make_Subprogram_Body (Loc,
+             Specification              => Specification (N),
+             Declarations               => Empty_List,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                 Statements         => New_List (
+                   Make_Null_Statement (Loc)),
+                 End_Label          =>
+                   End_Label (Handled_Statement_Sequence (N)))));
+         Set_Corresponding_Spec (N, Spec_Id);
+         Body_Deleted := True;
+      end if;
+
+      --  Now we can go on to analyze the body
 
       HSS := Handled_Statement_Sequence (N);
       Set_Actual_Subtypes (N, Current_Scope);
@@ -1223,7 +1258,9 @@ package body Sem_Ch6 is
                   Set_Has_Missing_Return (Id);
                end if;
 
-            elsif not Is_Machine_Code_Subprogram (Id) then
+            elsif not Is_Machine_Code_Subprogram (Id)
+              and then not Body_Deleted
+            then
                Error_Msg_N ("missing RETURN statement in function body", N);
             end if;
          end;
@@ -1293,7 +1330,13 @@ package body Sem_Ch6 is
             end loop;
          end if;
 
-         Check_References (Body_Id);
+         --  Check references in body unless it was deleted. Note that the
+         --  check of Body_Deleted here is not just for efficiency, it is
+         --  necessary to avoid junk warnings on formal parameters.
+
+         if not Body_Deleted then
+            Check_References (Body_Id);
+         end if;
       end;
    end Analyze_Subprogram_Body;