mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-13 08:29:53 +00:00
302 lines
10 KiB
Ada
302 lines
10 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- S T R U B --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2021-2022, 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;
|