hac_0.11.0_c596ed7c/src/manage/hac_sys-librarian.adb

-------------------------------------------------------------------------------------
--
--  HAC - HAC Ada Compiler
--
--  A compiler in Ada for an Ada subset
--
--  Copyright, license, etc. : see top package.
--
-------------------------------------------------------------------------------------
--

with HAC_Sys.Compiler,
     HAC_Sys.Librarian.Built_In_Packages,
     HAC_Sys.Parser.Helpers,
     HAC_Sys.Parser.Packages,
     HAC_Sys.Errors;

with Ada.Characters.Handling,
     Ada.Containers.Indefinite_Hashed_Maps,
     Ada.Exceptions,
     Ada.Strings.Hash,
     Ada.Text_IO.Text_Streams,
     Ada.Unchecked_Deallocation;

package body HAC_Sys.Librarian is

  ---------------------------------------------
  --  Introduce a new unit into the library  --
  ---------------------------------------------

  procedure Register_Unit (
    LD         : in out Library_Data;
    Descriptor : in     Library_Unit
  )
  is
    use Librarian.Library_Name_Mapping;
    UVFN : constant HAL.VString := HAL.To_Upper (Descriptor.full_name);
    is_new : Boolean;
  begin
    is_new := LD.Map.Find (UVFN) = No_Element;
    if not is_new then
      raise Program_Error with
        "Duplicate registration for unit " &
        HAL.To_String (Descriptor.full_name) &
        ". This case should be handled by Apply_WITH";
    end if;
    LD.Library.Append (Descriptor);
    LD.Map.Insert (UVFN, LD.Library.Last_Index);
    --  HAL.PUT_LINE ("Registering: " & Full_Name);
  end Register_Unit;

  procedure Change_Unit_Details (
    LD         : in out Library_Data;
    Descriptor : in     Library_Unit
  )
  is
    use Library_Name_Mapping;
    UVFN : constant HAL.VString := HAL.To_Upper (Descriptor.full_name);
    c : Cursor;
    book_nr : Positive;
  begin
    c := LD.Map.Find (UVFN);
    if c = No_Element then
      raise Program_Error with "Change_Unit_Status called on non-registered unit";
    end if;
    book_nr := Element (c);
    LD.Library.Replace_Element (book_nr, Descriptor);
  end Change_Unit_Details;

  procedure Enter_Library_Level_Def (
    CD             : in out Co_Defs.Compiler_Data;
    Full_Ident     : in     String;  --  "Main", "Standard.False", ...
    New_Entity     : in     Co_Defs.Entity_Kind;
    Base_Type      : in     Defs.Typen;
    Size           : in     Integer;
    Discrete_First : in     Defs.HAC_Integer := Defs.HAC_Integer'First;
    Discrete_Last  : in     Defs.HAC_Integer := Defs.HAC_Integer'Last
  )
  is
    use Ada.Characters.Handling, Defs;
    use type Nesting_level;
    Alfa_Ident       : constant Alfa := S2A (Full_Ident);
    Alfa_Ident_Upper : constant Alfa := S2A (To_Upper (Full_Ident));
    last : Index := CD.Id_Count;
  begin
    CD.Id_Count := CD.Id_Count + 1;
    --  Find the last library-level definition:
    while last > 0 and then CD.IdTab (last).lev > 0 loop
      last := last - 1;
    end loop;
    CD.IdTab (CD.Id_Count) :=
     (
      name             => Alfa_Ident_Upper,
      name_with_case   => Alfa_Ident,
      link             => last,
      entity           => New_Entity,
      read_only        => True,
      decl_kind        => Co_Defs.complete,
      xtyp             => (TYP            => Base_Type,
                           Ref            => 0,
                           Is_Range       => False,
                           Discrete_First => Discrete_First,
                           Discrete_Last  => Discrete_Last),
      block_or_pkg_ref => 0,
      normal           => True,
      lev              => 0,
      adr_or_sz        => Size
    );
    CD.Blocks_Table (0).Last_Id_Idx := CD.Id_Count;
    CD.CUD.level_0_def.Include (Alfa_Ident_Upper, CD.Id_Count);
  end Enter_Library_Level_Def;

  --  GNAT_Naming returns the file name that GNAT expects for a unit
  --  with the name Unit_Name.

  function GNAT_Naming (Unit_Name : String) return String is
    result : String := Ada.Characters.Handling.To_Lower (Unit_Name);
  begin
    for c of result loop
      if c = '.' then
        c := '-';
      end if;
    end loop;
    return result;
  end GNAT_Naming;

  procedure Set_Source_Access
    (LD          : in out Library_Data;
     exists       : Extended_Exists;
     open_source  : Extended_Open;
     close_source : Extended_Close) is
  begin
    LD.exists       := exists;
    LD.open_source  := open_source;
    LD.close_source := close_source;
  end Set_Source_Access;

  function Find_Unit_File_Name
    (LD        : Library_Data;
     Unit_Name : String)
  return String
  is
    GNAT_prefix : constant String := GNAT_Naming (Unit_Name);
    spec_fn : constant String := GNAT_prefix & ".ads";
    body_fn : constant String := GNAT_prefix & ".adb";
  begin
    if LD.exists (spec_fn) then
      return spec_fn;
    elsif LD.exists (body_fn) then
      return body_fn;
    else
      return "";
    end if;
  end Find_Unit_File_Name;

  procedure Activate_Unit (CD : in out Co_Defs.Compiler_Data; Upper_Name : in String) is
    use Co_Defs, Defs;
    unit_idx : Natural;
    upper_name_alfa : constant Alfa := S2A (Upper_Name);
  begin
    --  HAL.PUT_LINE ("WITH: Activating " & Upper_Name);
    --  Activate the unit itself:
    unit_idx := Parser.Helpers.Locate_Identifier
      (CD, upper_name_alfa, Level => 0, Level_0_Filter => False);
    CD.CUD.level_0_def.Include (upper_name_alfa, unit_idx);
    --  Only packages specifications need to have their items made visible.
    if CD.IdTab (unit_idx).entity = Paquetage then
      declare
        pkg_table_entry : Package_Table_Entry
          renames CD.Packages_Table (CD.IdTab (unit_idx).block_or_pkg_ref);
      begin
        for declaration_in_pkg_index in
          pkg_table_entry.first_public_declaration ..
          pkg_table_entry.last_public_declaration
        loop
          CD.CUD.level_0_def.Include
            (CD.IdTab (declaration_in_pkg_index).name, declaration_in_pkg_index);
        end loop;
      end;
    end if;
  end Activate_Unit;

  procedure Compile_WITHed_Unit (
    CD         : in out Co_Defs.Compiler_Data;
    LD         : in out Library_Data;
    Upper_Name : in     String
  )
  is
    fn : constant String := Find_Unit_File_Name (LD, Upper_Name);
    use Defs, Errors;
    as_specification : Boolean;
    needs_body : Boolean;
    unit : Library_Unit :=
      (full_name  => HAL.To_VString (Upper_Name),
       kind       => Package_Declaration,  --  Temporary value
       status        => In_Progress,       --  Temporary value.
       id_index      => Co_Defs.No_Id,     --  Temporary value.
       id_body_index => Co_Defs.No_Id,     --  Temporary value.
       spec_context  => Co_Defs.Id_Maps.Empty_Map);
  begin
    --
    --  Add new unit name to the library catalogue
    --
    --
    Register_Unit (LD, unit);
    --
    if fn = "" then
      Error (
        CD,
        err_library_error,
        "no file found matching the name " & GNAT_Naming (Upper_Name) & ".ad*",
        major
      );
    else
      as_specification := fn (fn'Last) = 's';
      Compiler.Compile_Unit
        (CD, LD, Upper_Name, fn, as_specification,
         Co_Defs.No_Id,
         unit.id_index,
         unit.spec_context,
         unit.kind,
         needs_body);
      --
      if as_specification then
        case unit.kind is
          when Subprogram_Unit =>
            unit.status := Body_Postponed;
          when Package_Declaration =>
            if needs_body then
              unit.status := Body_Postponed;
            else
              unit.status := Spec_Only;
            end if;
          when Package_Body =>
            null;  --  Not relevant (spec.)
        end case;
      else
        unit.status := Done;
      end if;
      Change_Unit_Details (LD, unit);
      --
      --  Activate unit library-level declaration for the first time.
      --  It must be visible to the WITH-ing unit.
      --
      Activate_Unit (CD, Upper_Name);
    end if;
  end Compile_WITHed_Unit;

  procedure Apply_WITH (
    CD         : in out Co_Defs.Compiler_Data;
    LD         : in out Library_Data;
    Upper_Name : in     String
  )
  is
    use Ada.Exceptions, Defs, HAL, Errors;
    UVN : constant VString := To_VString (Upper_Name);
  begin
    if LD.Map.Contains (UVN) then
      --  Definition is already somewhere in CD (from the compilation
      --  of another unit), we just need to reactivate it.
      --  This situation includes the duplicate WITH case (not nice but correct).
      --  Packages Standard and HAL are also reactivated on second WITH (implicitly for Standard).
      if LD.Library.Element (LD.Map.Element (UVN)).status = In_Progress then
        raise Circular_Unit_Dependency with Upper_Name;
      end if;
      Activate_Unit (CD, Upper_Name);
    elsif Upper_Name = "STANDARD" then
      Built_In_Packages.Define_and_Register_Standard (CD, LD);
    elsif Upper_Name = "INTERFACES" then
      Built_In_Packages.Define_and_Register_Interfaces (CD, LD);
    elsif Upper_Name = HAL_Name then
      Built_In_Packages.Define_and_Register_HAL (CD, LD);
    elsif Upper_Name = "HAC_PACK" then
      Error (
        CD,
        err_library_error,
        "the new name of HAC_Pack is " & HAL_Name,
        major
      );
    else
      begin
        Compile_WITHed_Unit (CD, LD, Upper_Name);
      exception
        when E : Circular_Unit_Dependency =>
          raise Circular_Unit_Dependency with Upper_Name & " -> " & Exception_Message (E);
      end;
    end if;
  end Apply_WITH;

  procedure Apply_WITH_USE_Standard (
    CD         : in out Co_Defs.Compiler_Data;
    LD         : in out Library_Data
  )
  is
  begin
    Apply_WITH (CD, LD, "STANDARD");
    Parser.Packages.Apply_USE_Clause (
      CD, Library_Level,
      Parser.Helpers.Locate_Identifier (CD, Defs.S2A ("STANDARD"), 0)
    );
  end Apply_WITH_USE_Standard;

  --  Here we have the default behaviour for Library_Data's open source
  --  and close source routines.
  --  It can be a template for a customized, more elaborate, abstracted
  --  file system for getting source (and other) streams.
  --  The routines can also used as end point of the said abstracted
  --  file system when "physical" files are involved.

  type Text_File_Access is access Ada.Text_IO.File_Type;

  package Default_File_Name_Mapping is new Ada.Containers.Indefinite_Hashed_Maps
    (Key_Type        => String,
     Element_Type    => Text_File_Access,
     Hash            => Ada.Strings.Hash,
     Equivalent_Keys => "=");

  --  Here we have a global mapping
  --  !! Not task-safe -> wrap into a protected object!
  default_file_names : Default_File_Name_Mapping.Map;

  procedure default_open_file_proc (Name : String; Stream : out Co_Defs.Source_Stream_Access) is
    use Ada.Text_IO;
    new_file : constant Text_File_Access := new File_Type;
  begin
    default_file_names.Insert (Name, new_file);
    Open (new_file.all, In_File, Name);
    Stream := Co_Defs.Source_Stream_Access (Text_Streams.Stream (new_file.all));
  end default_open_file_proc;

  procedure default_close_file_proc (Name : String) is
    use Ada.Text_IO;
    procedure Free is new Ada.Unchecked_Deallocation (File_Type, Text_File_Access);
    file : Text_File_Access;
  begin
    if default_file_names.Contains (Name) then
      file := default_file_names.Element (Name);
      if file /= null then
        if Is_Open (file.all) then
          Close (file.all);
        end if;
        Free (file);
      end if;
      default_file_names.Delete (Name);
    end if;
  end default_close_file_proc;

end HAC_Sys.Librarian;