libadalang_tools_24.0.0_d864b5a8/src/tgen/tgen-gen_strategies_utils.adb

------------------------------------------------------------------------------
--                                                                          --
--                                  TGen                                    --
--                                                                          --
--                       Copyright (C) 2022, AdaCore                        --
--                                                                          --
-- TGen  is  free software; you can redistribute it and/or modify it  under --
-- under  terms of  the  GNU General  Public License  as  published by  the --
-- Free  Software  Foundation;  either version 3, or  (at your option)  any --
-- later version. This software  is distributed in the hope that it will be --
-- useful but  WITHOUT  ANY  WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY  or  FITNESS  FOR A PARTICULAR PURPOSE.                  --
--                                                                          --
-- As a special  exception  under  Section 7  of  GPL  version 3,  you are  --
-- granted additional  permissions described in the  GCC  Runtime  Library  --
-- Exception, version 3.1, as published by the Free Software Foundation.    --
--                                                                          --
-- You should have received a copy of the GNU General Public License and a  --
-- copy of the GCC Runtime Library Exception along with this program;  see  --
-- the files COPYING3 and COPYING.RUNTIME respectively.  If not, see        --
-- <http://www.gnu.org/licenses/>.                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;
with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;

with GNATCOLL.VFS;

with TGen.Types.Record_Types; use TGen.Types.Record_Types;

package body TGen.Gen_Strategies_Utils is

   -------------------------
   -- Get_Subprogram_Data --
   -------------------------

   function Extract_Subprogram_Data
     (Subp : Basic_Decl'Class)
      return Subprogram_Data
   is
      Spec : constant Subp_Spec := Subp.P_Subp_Spec_Or_Null.As_Subp_Spec;

      Name                 : constant Text_Type :=
        Subp.P_Defining_Name.F_Name.Text;
      Fully_Qualified_Name : constant Text_Type := Subp.P_Fully_Qualified_Name;
      Parent_Package       : constant Text_Type :=
        Subp.P_Top_Level_Decl (Subp.Unit).P_Defining_Name.F_Name.Text;
      Params_Data          : constant Parameters_Data_Vector :=
        Extract_Parameters_Data (Subp);
      Kind                 : constant Ada_Subp_Kind := Spec.F_Subp_Kind;
      Precondition         : Unbounded_Text_Type;

      Result : Subprogram_Data (Kind);

      Pre_Expr : constant Expr :=
        Subp.P_Get_Aspect_Spec_Expr (+String'("Pre"));
   begin
      begin
         Precondition := +(if Is_Null (Pre_Expr)
                          then To_Text ("True")
                          else Pre_Expr.Text);
      exception
         when Property_Error =>
            --  No precondition => generated values are always valid

            Precondition := +String'("True");
      end;
      case Kind is
         when Ada_Subp_Kind_Function =>
            return
              (Kind                             => Ada_Subp_Kind_Function,
               Name                             => +Name,
               Fully_Qualified_Name             => +Fully_Qualified_Name,
               Parent_Package                   => +Parent_Package,
               Parameters_Data                  => Params_Data,
               Return_Type_Fully_Qualified_Name =>
                  +(if not Is_Null (Spec.P_Return_Type)
                    then Spec.P_Return_Type.P_Fully_Qualified_Name
                    else ""),
               Return_Type_Parent_Package       =>
                  +Spec.P_Top_Level_Decl (Spec.Unit).P_Fully_Qualified_Name,
               Precondition                     => Precondition,
               others                           => <>);

         when Ada_Subp_Kind_Procedure =>
            return
              (Kind                 => Ada_Subp_Kind_Procedure,
               Name                 => +Name,
               Fully_Qualified_Name => +Fully_Qualified_Name,
               Parent_Package       => +Parent_Package,
               Parameters_Data      => Params_Data,
               Precondition         => Precondition,
               others               => <>);
      end case;
      return Result;
   end Extract_Subprogram_Data;

   --------------------------
   -- Extract_Package_Data --
   --------------------------

   function Extract_Package_Data
     (Pkg_Decl : Package_Decl)
      return Package_Data
   is
      Subpackages : Package_Data_Vectors.Vector;
      Subprograms : Subprograms_Data_Vectors.Vector;

      function Visit (Node : Ada_Node'Class) return Visit_Status;

      function Visit (Node : Ada_Node'Class) return Visit_Status is
      begin
         if Kind (Node) in Ada_Package_Decl then
            Subpackages.Append
              (new Package_Data'
                 (Extract_Package_Data (Node.As_Package_Decl)));
            return Into;
         elsif Kind (Node) in Ada_Subp_Decl then
            Subprograms.Append
              (Extract_Subprogram_Data
                 (Node.As_Basic_Decl));
            return Over;
         end if;
         return Over;
      end Visit;
   begin
      for Decl of Pkg_Decl.F_Public_Part.F_Decls loop
         Decl.Traverse (Visit'Access);
      end loop;
      if not Pkg_Decl.F_Private_Part.Is_Null then
         for Decl of Pkg_Decl.F_Private_Part.F_Decls loop
            Decl.Traverse (Visit'Access);
         end loop;
      end if;
      return Package_Data'(Subpackages, Subprograms, Pkg_Decl);
   end Extract_Package_Data;

   -----------------------------
   -- Extract_Parameters_Data --
   -----------------------------

   function Extract_Parameters_Data
     (Subp : Basic_Decl'Class)
      return Parameters_Data_Vector
   is
      Subp_Params : constant Params :=
        (if Subp.Is_Null then
            raise Program_Error
         else
            Get_Subp_Params (Subp));

      Params_Data : Parameters_Data_Vector;
      Index : Positive := 1;

   begin
      if Subp_Params.Is_Null then
         return Params_Data;
      end if;
      for Subp_Param_Spec of Subp_Params.F_Params loop
         declare
            Parameters_Type : constant Defining_Name :=
              Subp_Param_Spec.F_Type_Expr.
                P_Designated_Type_Decl.P_Defining_Name;

            Param_Mode : constant TGen.Subprograms.Parameter_Mode :=
              (case Kind (Subp_Param_Spec.F_Mode) is
                  when Ada_Mode_Default | Ada_Mode_In => In_Mode,
                  when Ada_Mode_In_Out => In_Out_Mode,
                  when Ada_Mode_Out => Out_Mode,
                  when others => Out_Mode);

            Type_Name                 : constant Unbounded_Text_Type :=
              To_Unbounded_Text (
                if Is_Null (Parameters_Type)
                then ""
                else (Parameters_Type.F_Name.Text));
            Type_Fully_Qualified_Name : constant Unbounded_Text_Type :=
              To_Unbounded_Text
                (if Is_Null (Parameters_Type)
                 then ""
                 else Parameters_Type.P_Basic_Decl.P_Fully_Qualified_Name);
            Type_Parent_Package       : constant Unbounded_Text_Type :=
              To_Unbounded_Text
                (if Is_Null (Parameters_Type)
                 then ""
                 else Parameters_Type.P_Basic_Decl.P_Top_Level_Decl
                        (Parameters_Type.Unit).P_Defining_Name.F_Name.Text);
         begin
            for Parameter of Subp_Param_Spec.F_Ids loop
               declare
                  Name : constant Unbounded_Text_Type :=
                    To_Unbounded_Text (Parameter.F_Name.Text);

               begin

                  Params_Data.Append
                    (Parameter_Data'
                       (Name                      => Name,
                        Index                     => Index,
                        Mode                      => Param_Mode,
                        Type_Name                 => Type_Name,
                        Type_Fully_Qualified_Name => Type_Fully_Qualified_Name,
                        Type_Parent_Package       => Type_Parent_Package));
               end;

               Index := Index + 1;
            end loop;
         end;
      end loop;

      return Params_Data;
   end Extract_Parameters_Data;

   --  This is duplicated code from lal_tools. For now we want to avoid
   --  bringing a dependency to lal_tools.

   ----------------------
   -- Unit_To_Filename --
   ----------------------

   function Unit_To_Filename
     (Project   : Project_Type;
      Unit_Name : String;
      Part      : Unit_Parts) return String
   is
      use GNATCOLL.VFS;
   begin
      return +Project.File_From_Unit
        (Unit_Name => Unit_Name,
         Part      => Part,
         Language  => "Ada",
         File_Must_Exist => False);
   end Unit_To_Filename;

   ---------------------
   -- Get_Subp_Params --
   ---------------------

   function Get_Subp_Params
     (Subp : Basic_Decl'Class)
      return Params is
     (Get_Subp_Spec_Params (Get_Subp_Spec (Subp)));

   -------------------
   -- Get_Subp_Spec --
   -------------------

   function Get_Subp_Spec (Subp : Basic_Decl'Class) return Base_Subp_Spec is
     (if Subp.Is_Null then No_Base_Subp_Spec
      else Subp.P_Subp_Spec_Or_Null (True));

   --------------------------
   -- Get_Subp_Spec_Params --
   --------------------------

   function Get_Subp_Spec_Params
     (Subp_Spec : Base_Subp_Spec'Class)
      return Params is
   begin
      if Subp_Spec.Is_Null then
         return No_Params;
      end if;

      case Ada_Base_Subp_Spec (Subp_Spec.Kind) is
         when Ada_Entry_Spec_Range
            => return Subp_Spec.As_Entry_Spec.F_Entry_Params;
         when Ada_Enum_Subp_Spec_Range
            => return No_Params;
         when Ada_Subp_Spec_Range
            => return Subp_Spec.As_Subp_Spec.F_Subp_Params;
         when Ada_Synthetic_Binary_Spec
            => return No_Params;
         when Ada_Synthetic_Unary_Spec
            => return No_Params;
      end case;
   end Get_Subp_Spec_Params;

   -----------------------------
   -- Type_Strat_Package_Name --
   -----------------------------

   function Type_Strat_Package_Name (Package_Name : String) return String is
   begin
      if Package_Name = "Standard" then
         return "Standard_Type_Strategies";
      else
         return Package_Name & ".Type_Strategies";
      end if;
   end Type_Strat_Package_Name;

   -----------
   -- Strip --
   -----------

   function Strip (Package_Name : String) return String is
   begin
      return Package_Name
        (Package_Name'First
         .. (Index (Package_Name, ".", Package_Name'Last, Backward) - 1));
   end Strip;

   -------------------
   -- Get_All_Types --
   -------------------

   function Get_All_Types (Self : Typ'Class) return Typ_Set is
      Result : Typ_Set;
   begin
      case Kind (Self) is
         when Non_Disc_Record_Kind =>
            for Comp of Nondiscriminated_Record_Typ (Self).Component_Types loop
               Result.Insert (Comp);
            end loop;
         when Disc_Record_Kind =>
            declare
               R : constant Discriminated_Record_Typ :=
                 Discriminated_Record_Typ (Self);
            begin

               --  For now, we do not insert anonymous types. Left as a TODO

               for T of R.Component_Types loop
                  if not T.Get.Is_Anonymous then
                     Result.Include (T);
                  end if;
               end loop;

               for T of R.Discriminant_Types loop
                  if not T.Get.Is_Anonymous then
                     Result.Include (T);
                  end if;
               end loop;

               if R.Variant /= null then
                  for V of R.Variant.Variant_Choices loop
                     Result.Union
                       (Get_All_Types
                          (Discriminated_Record_Typ'
                               (Constrained        => False,
                                Name               => R.Name,
                                Last_Comp_Unit_Idx => R.Last_Comp_Unit_Idx,
                                Fully_Private      => R.Fully_Private,
                                Static_Gen         => R.Static_Gen,
                                Component_Types    => V.Components,
                                Mutable            => False,
                                Discriminant_Types => Component_Maps.Empty_Map,
                                Variant            => V.Variant)));
                  end loop;
               end if;
            end;

            --  TODO: add arrays

         when others =>
            null;
      end case;

      return Result;
   end Get_All_Types;

end TGen.Gen_Strategies_Utils;