------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S T R U B --
-- --
-- B o d y --
-- --
-- Copyright (C) 2021-2025, Free Software Foundation, Inc. --
-- --
-- GNAT 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Package containing utility procedures related to Stack Scrubbing
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Errout; use Errout;
with Namet; use Namet;
with Nlists; use Nlists;
with Sem_Eval; use Sem_Eval;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stringt; use Stringt;
package body Strub is
-----------------------
-- Local Subprograms --
-----------------------
function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id;
-- Return a pragma Machine_Attribute (Id, "strub"[, "mode"]) node
-- if Id has one.
function Strub_Pragma_Arg (Item : Node_Id) return Node_Id is
(Get_Pragma_Arg
(Next (Next (First (Pragma_Argument_Associations (Item))))));
-- Return the pragma argument holding the strub mode associated
-- with Item, a subprogram, variable, constant, or type. Bear in
-- mind that strub pragmas with an explicit strub mode argument,
-- naming access-to-subprogram types, are applied to the
-- designated subprogram type.
function Strub_Pragma_Arg_To_String (Item : Node_Id) return String is
(To_String (Strval (Expr_Value_S (Item))));
-- Extract and return as a String the strub mode held in a node
-- returned by Strub_Pragma_Arg.
function Strub_Pragma_Mode
(Id : Entity_Id;
Item : Node_Id) return Strub_Mode;
-- Return the strub mode associated with Item expressed in Id.
-- Strub_Pragma_P (Id) must hold.
---------------------------
-- Check_Same_Strub_Mode --
---------------------------
procedure Check_Same_Strub_Mode
(Dest, Src : Entity_Id;
Report : Boolean := True)
is
Src_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Src);
Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);
begin
if Dest_Strub_Mode = Src_Strub_Mode then
return;
end if;
-- Internal is not part of the interface, it's an *internal*
-- implementation detail, so consider it equivalent to unspecified here.
-- ??? -fstrub=relaxed|strict makes them interface-equivalent to
-- Callable or Disabled, respectively, but we don't look at that flag in
-- the front-end, and it seems undesirable for that flag to affect
-- whether specifications are conformant. Maybe there should be some
-- means to specify Callable or Disabled along with Internal?
if Dest_Strub_Mode in Unspecified | Internal
and then Src_Strub_Mode in Unspecified | Internal
then
return;
end if;
if not Report then
return;
end if;
if Src_Strub_Mode /= Unspecified then
Error_Msg_Sloc := Sloc (Find_Explicit_Strub_Pragma (Src));
else
Error_Msg_Sloc := Sloc (Src);
end if;
Error_Msg_Node_2 := Src;
Error_Msg_NE ("& requires the same `strub` mode as &#",
(if Dest_Strub_Mode /= Unspecified
then Find_Explicit_Strub_Pragma (Dest)
else Dest),
Dest);
end Check_Same_Strub_Mode;
----------------------------
-- Compatible_Strub_Modes --
----------------------------
function Compatible_Strub_Modes
(Dest, Src : Entity_Id) return Boolean
is
Src_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Src);
Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);
begin
return Src_Strub_Mode = Dest_Strub_Mode
or else At_Calls not in Src_Strub_Mode | Dest_Strub_Mode;
end Compatible_Strub_Modes;
---------------------
-- Copy_Strub_Mode --
---------------------
procedure Copy_Strub_Mode (Dest, Src : Entity_Id) is
Strub : Node_Id := Find_Explicit_Strub_Pragma (Src);
Src_Strub_Mode : constant Strub_Mode := Strub_Pragma_Mode (Src, Strub);
begin
pragma Assert (Explicit_Strub_Mode (Dest) = Unspecified);
-- Refrain from copying Internal to subprogram types.
-- It affects code generation for the subprogram,
-- but it has no effect on its type or interface.
if Src_Strub_Mode = Unspecified
or else (Ekind (Dest) = E_Subprogram_Type
and then Src_Strub_Mode = Internal)
then
return;
end if;
Strub := New_Copy (Strub);
Set_Next_Rep_Item (Strub, First_Rep_Item (Dest));
Set_First_Rep_Item (Dest, Strub);
Set_Has_Gigi_Rep_Item (Dest);
end Copy_Strub_Mode;
-------------------------
-- Explicit_Strub_Mode --
-------------------------
function Explicit_Strub_Mode (Id : Entity_Id) return Strub_Mode is
Item : constant Node_Id := Find_Explicit_Strub_Pragma (Id);
begin
return Strub_Pragma_Mode (Id, Item);
end Explicit_Strub_Mode;
--------------------------------
-- Find_Explicit_Strub_Pragma --
--------------------------------
function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id is
Item : Node_Id;
begin
if not Has_Gigi_Rep_Item (Id) then
return Empty;
end if;
Item := First_Rep_Item (Id);
while Present (Item) loop
if Strub_Pragma_P (Item) then
return Item;
end if;
Item := Next_Rep_Item (Item);
end loop;
return Empty;
end Find_Explicit_Strub_Pragma;
-----------------------
-- Strub_Pragma_Mode --
-----------------------
function Strub_Pragma_Mode
(Id : Entity_Id;
Item : Node_Id) return Strub_Mode
is
Arg : Node_Id := Empty;
begin
-- ??? Enumeration literals, despite being conceptually functions, have
-- neither bodies nor stack frames, and it's not clear whether it would
-- make more sense to treat them as subprograms or as constants, but
-- they can be renamed as functions. Should we require all literals of
-- a type to have the same strub mode? Rule out their annotation?
if Ekind (Id) in E_Subprogram_Type
| Overloadable_Kind
| Generic_Subprogram_Kind
then
if Item = Empty then
return Unspecified;
end if;
Arg := Strub_Pragma_Arg (Item);
if Arg = Empty then
return At_Calls;
end if;
declare
Str : constant String := Strub_Pragma_Arg_To_String (Arg);
begin
if Str'Length /= 8 then
return Unspecified;
end if;
case Str (Str'First) is
when 'a' =>
if Str = "at-calls" then
return At_Calls;
end if;
when 'i' =>
if Str = "internal" then
return Internal;
end if;
when 'c' =>
if Str = "callable" then
return Callable;
end if;
when 'd' =>
if Str = "disabled" then
return Disabled;
end if;
when others =>
null;
end case;
return Unspecified;
end;
-- Access-to-subprogram types and variables can be treated just like
-- other access types, because the pragma logic has already promoted to
-- subprogram types any annotations applicable to them.
elsif Ekind (Id) in Type_Kind -- except E_Subprogram_Type, covered above
| Scalar_Kind
| Object_Kind
| Named_Kind
then
if Item = Empty then
return Unspecified;
end if;
Arg := Strub_Pragma_Arg (Item);
if Arg /= Empty then
-- A strub parameter is not applicable to variables,
-- and will be ignored.
return Unspecified;
end if;
return Enabled;
else
pragma Assert (Item = Empty);
return Not_Applicable;
end if;
end Strub_Pragma_Mode;
--------------------
-- Strub_Pragma_P --
--------------------
function Strub_Pragma_P
(Item : Node_Id) return Boolean is
(Nkind (Item) = N_Pragma
and then Pragma_Name (Item) = Name_Machine_Attribute
and then
Strub_Pragma_Arg_To_String
(Get_Pragma_Arg
(Next (First (Pragma_Argument_Associations (Item)))))
= "strub");
end Strub;