⟦1c5a9e97a⟧

TextFile

with Text_Io;
use Text_Io;
with Calendar;
with Time_Library_1;
use Time_Library_1;
with Stack_Pkg;

package body Buffer_File_Package --| File management for the SI

    is
    use String_Lists;  -- declared in the package spec

    subtype Date_String is String (1 .. 8);
    subtype Time_String is String (1 .. 8);

    No_Date : constant Date_String := (others => ' ');
    No_Time : constant Time_String := (others => ' ');
    No_Name : constant String_Pkg.String_Type := Create ("");

    -- note: NO_FILENAME is declared in the spec because it is used
    -- as a default value for an external procedure

    type Table_Entry_Record is
    --| Record format for table entries
        record
            Package_Ada_Name : String_Pkg.String_Type := No_Name;
            --| Fully qualified package name
            Package_Filename : Filename_Prefix_String := No_Filename;
            --| Filename prefix
            Withed_Units : String_Pkg.String_Type := No_Name;
            --| List of units named in the context clause of a specification
            Date_Created : Date_String := No_Date;
            --| Date the file was created
            Time_Created : Time_String := No_Time;
            --| Time the file was created
        end record;


    -- Function EQUAL for the instantiation of the Lists package
    function Table_Equal (X, Y : in Table_Entry_Record) return Boolean;

    package Internal_List_Package is new Lists
                                            (Table_Entry_Record, Table_Equal);
    use Internal_List_Package;

    Internal_Table : Internal_List_Package.List;
    --| A linked list of table entry records, for equating package names
    --| with their filename prefix for instrumenting information files.  The
    --| list is built by reading the external file.

    Internal_Table_Created : Boolean := False;
    Internal_Table_Changed : Boolean := False;

    External_File : Text_Io.File_Type;
    --| The external file of package name, filename prefix information.
    --| The internal table is written to the external file at the end
    --| of instrumentation.

    Terminator : constant Character := '*';
    --| Mark the end of a table_entry_record field in the external file

    subtype Long_String is String (1 .. 255);
    --| Used for reading a line of text from one of the files.  It is
    --| assumed that most lines will be less than 255 characters and
    --| this choice should be adequate most of the time.  Procedures
    --| which do the reading must allow for cases where lines are longer
    --| than 255.


    --| Varaibles for marking and releasing sections in the Buffer_File

    package Index_Stack_Pkg is new Stack_Pkg (Dio.Positive_Count);
    Index_Stack : Index_Stack_Pkg.Stack;
    Starting_Index : Dio.Positive_Count;


    ------------------------------------------------------------------------
    --  Local procedure specificatons
    -------------------------------------------------------------------------


    ----------------------------------------------------------------------------

    procedure Create_Internal_Table;
    --| Reads the external file and build an internal version of it
    --| as a linked list.

    --------------------------------------------------------------------------

    function Filename_In_Table
                (Filename : in Filename_Prefix_String) return Boolean;

    --| Searches the Internal_Table for the occurrence of the
    --| specified filename prefix.

    ----------------------------------------------------------------------------

    function Make_Filename_Prefix (Package_Name : in String)
                                  return Filename_Prefix_String;

    --| Formulates and returns a unique filename prefix for each package name.

    ----------------------------------------------------------------------------

    function Convert_List_To_String_Type
                (L : in String_List) return String_Type;
    --| Converts a list of string_types to a single string_type
    --| with each element separated by one blank.

    ---------------------------------------------------------

    function Convert_String_To_List (S : in String) return String_List;
    --| Converts a literal string into a list of string_types.

    ---------------------------------------------------------

    function Get_Fixed_Length_Table_Entry (Length : in Positive) return String;
    --| Returns a string of the next "length" characters read
    --| from the external file.

    ---------------------------------------------------------

    function Get_Variable_Length_Table_Entry return String_Type;
    --| Reads any number of characters in the external file until
    --| the terminator character ('*') is found and returns them
    --| as a string_type.

    ---------------------------------------------------------

    procedure Get_Internal_Table_Entry (Package_Name : in String;
                                        Table_Entry : out Table_Entry_Record;
                                        Found : in out Boolean);
    --| Scan the internal table for an entry for Package_Name,
    --| and if found, pass it back to the calling procedure.

    ---------------------------------------------------------

    function Start_Package (Package_Name : in String)
                           return Filename_Prefix_String;

    --| Create an entry in the Internal_Table for this package,
    --| and return the unique filename prefix.

    ---------------------------------------------------------

    function Get_Filename_Prefix (Package_Name : in String)
                                 return Filename_Prefix_String;

    --| If the package is in the table, return its filename prefix.  If
    --| there isn't an entry return No_Filename.

    ---------------------------------------------------------

    procedure Delete_Internal_Table_Entry (Package_Name : in String);
    --| Delete the entry for this package from the Internal_Table.



    ---------------------------------------------------------------
    --  External procedures for managing the package tracing files.
    ---------------------------------------------------------------


    procedure Create_Package_Files (Package_Name : in String;
                                    Which_Files : in File_Group) is
        --| Set up the requested set of package tracing files.

        Package_Filename_Prefix : Filename_Prefix_String;

    begin

        -- Call Start_Package which will make an entry in the internal
        -- table and then return the unique filename prefix
        Package_Filename_Prefix := Start_Package (Package_Name);

        if Which_Files /= Private_Files then

            -- create the public_spec file
            begin

                Dio.Open (Public_Spec_File, Out_File,
                          Package_Filename_Prefix & Public_Spec_File_Suffix);
                Dio.Delete (Public_Spec_File);
                Dio.Create (Public_Spec_File, Out_File,
                            Package_Filename_Prefix & Public_Spec_File_Suffix);

            exception
                when Dio.Name_Error =>
                    Dio.Create (Public_Spec_File, Out_File,
                                Package_Filename_Prefix &
                                   Public_Spec_File_Suffix);
            end;

            -- create the public_body file
            begin

                Dio.Open (Public_Body_File, Out_File,
                          Package_Filename_Prefix & Public_Body_File_Suffix);
                Dio.Delete (Public_Body_File);
                Dio.Create (Public_Body_File, Out_File,
                            Package_Filename_Prefix & Public_Body_File_Suffix);

            exception
                when Dio.Name_Error =>
                    Dio.Create (Public_Body_File, Out_File,
                                Package_Filename_Prefix &
                                   Public_Body_File_Suffix);
            end;

        end if; -- Which_Files /= Private_Files

        if Which_Files /= Public_Files then

            -- create the private_spec file
            begin

                Dio.Open (Private_Spec_File, Out_File,
                          Package_Filename_Prefix & Private_Spec_File_Suffix);
                Dio.Delete (Private_Spec_File);
                Dio.Create (Private_Spec_File, Out_File,
                            Package_Filename_Prefix & Private_Spec_File_Suffix);

            exception
                when Dio.Name_Error =>
                    Dio.Create (Private_Spec_File, Out_File,
                                Package_Filename_Prefix &
                                   Private_Spec_File_Suffix);
            end;

            -- create the private_body file
            begin

                Dio.Open (Private_Body_File, Out_File,
                          Package_Filename_Prefix & Private_Body_File_Suffix);
                Dio.Delete (Private_Body_File);
                Dio.Create (Private_Body_File, Out_File,
                            Package_Filename_Prefix & Private_Body_File_Suffix);

            exception
                when Dio.Name_Error =>
                    Dio.Create (Private_Body_File, Out_File,
                                Package_Filename_Prefix &
                                   Private_Body_File_Suffix);
            end;
        end if;   -- Which_Files /= Public_Files
    end Create_Package_Files;

    ---------------------------------------------------------

    procedure Close_Package_Files (Which_Files : in File_Group) is
        --| Close the specified group of package tracing files.

    begin
        if Which_Files /= Private_Files then
            Dio.Close (Public_Spec_File);
            Dio.Close (Public_Body_File);
        end if;

        if Which_Files /= Public_Files then
            Dio.Close (Private_Spec_File);
            Dio.Close (Private_Body_File);
        end if;

    exception
        when others =>
            null;
    end Close_Package_Files;

    ----------------------------------------------------------------------

    procedure Reopen_Private_Files (Package_Name : in String) is
        --| Open the private files for the given package and set
        --| the file index to the end so that further writes are
        --| appended to the file rather that overwriting it.

        Package_Filename_Prefix : Filename_Prefix_String;
        File_Index : Dio.Count;

    begin
        Package_Filename_Prefix := Get_Filename_Prefix (Package_Name);

        -- If the files are not empty set the index to the next write
        -- write position, so the current stuff is not overwritten.
        Dio.Open (Private_Spec_File, Inout_File,
                  Package_Filename_Prefix & Private_Spec_File_Suffix);

        File_Index := Dio.Size (Private_Spec_File);
        if File_Index /= 0 then
            Dio.Set_Index (Private_Spec_File, File_Index + 1);
        end if;

        Dio.Open (Private_Body_File, Inout_File,
                  Package_Filename_Prefix & Private_Body_File_Suffix);

        File_Index := Dio.Size (Private_Body_File);
        if File_Index /= 0 then
            Dio.Set_Index (Private_Body_File, File_Index + 1);
        end if;

    exception
        when others =>
            null;

    end Reopen_Private_Files;

    ---------------------------------------------------------------------------

    function Package_Files_Exist
                (Package_Name : in String; Which_Files : in File_Group)
                return Boolean is
        --| See if the requested set of instrumenting information files
        --| exist for the given package.  Both the spec and body file must
        --| exist, as the body contains the bodies for the subprograms
        --| declared in the spec file.  If one exists without the other,
        --| delete it and return false.

        Filename_Prefix : Filename_Prefix_String :=
           Get_Filename_Prefix (Package_Name);

        Public_Spec_Exists : Boolean := True;
        Public_Body_Exists : Boolean := True;
        Private_Spec_Exists : Boolean := True;
        Private_Body_Exists : Boolean := True;
        Dio_File : Dio.File_Type;

    begin
        if Filename_Prefix = No_Filename then
            -- they don't exist
            return False;
        end if;

        -- The internal table has an entry for the given package name.
        -- Make sure that the necessary files exist and can be opened.
        -- If some of the files exist and not the others, delete those
        -- that do and update the table.  This could happen if the user
        -- has deleted the files other than by re-instrumenting...

        if Which_Files /= Private_Files then

            -- check if the public spec and body files exist
            begin
                Dio.Open (Dio_File, In_File,
                          Filename_Prefix & Public_Spec_File_Suffix);
                Dio.Close (Dio_File);
            exception
                when others =>
                    Public_Spec_Exists := False;
            end;

            begin
                Dio.Open (Dio_File, In_File,
                          Filename_Prefix & Public_Body_File_Suffix);
                Dio.Close (Dio_File);
            exception
                when others =>
                    Public_Body_Exists := False;
            end;

            if Which_Files = Public_Files then
                if not (Public_Spec_Exists and Public_Body_Exists) then
                    Delete_Package_Files
                       (Package_Name, Public_Files, Filename_Prefix);
                    return False;
                end if;
                return True;
            end if;
        end if;     -- Which_Files /= Private_Files

        if Which_Files /= Public_Files then

            -- check if the private spec and body files exist
            begin
                Dio.Open (Dio_File, In_File,
                          Filename_Prefix & Private_Spec_File_Suffix);
                Dio.Close (Dio_File);
            exception
                when others =>
                    Private_Spec_Exists := False;
            end;

            begin
                Dio.Open (Dio_File, In_File,
                          Filename_Prefix & Private_Body_File_Suffix);
                Dio.Close (Dio_File);
            exception
                when others =>
                    Private_Body_Exists := False;
            end;

            if Which_Files = Private_Files then
                if not (Private_Spec_Exists and Private_Body_Exists) then
                    Delete_Package_Files
                       (Package_Name, Private_Files, Filename_Prefix);
                    return False;
                end if;
                return True;
            end if;
        end if;     -- Which_Files /= Public_Files


        -- if we've gotten this far without hitting one of the
        -- returns then Which_Files = All_Files
        if not (Public_Spec_Exists and Public_Body_Exists and
                Private_Spec_Exists and Private_Body_Exists) then
            Delete_Package_Files (Package_Name, All_Files, Filename_Prefix);
            return False;
        end if;

        return True;

    end Package_Files_Exist;

    -----------------------------------------------------------------------------

    procedure Delete_Package_Files (Package_Name : in String;
                                    Which_Files : in File_Group := All_Files;
                                    Current_Filename_Prefix : in
                                       Filename_Prefix_String := No_Filename) is
        --| Delete the indicated set of package tracing files.  If all the
        --| files are deleted, then also delete the internal table entry for
        --| the package.

        Dio_File : Dio.File_Type;
        Package_Filename_Prefix : Filename_Prefix_String;

    begin

        -- if this procedure is called from Package_Files_Exist then
        -- the filename prefix has already been looked up, and is
        -- passed as Current_Filename_Prefix.
        if Current_Filename_Prefix = No_Filename then
            Package_Filename_Prefix := Get_Filename_Prefix (Package_Name);
        else
            Package_Filename_Prefix := Current_Filename_Prefix;
        end if;

        -- if the files can be opened, then they exist.  Delete them.
        -- Otherwise, there is nothing to delete so ignore it.
        if Package_Filename_Prefix /= No_Filename then

            if Which_Files /= Private_Files then

                -- delete the public_spec_file
                begin
                    Dio.Open (Dio_File, Out_File, Package_Filename_Prefix &
                                                     Public_Spec_File_Suffix);
                    Dio.Delete (Dio_File);
                exception
                    when Dio.Name_Error =>
                        null;
                end;

                -- delete the public_body_file
                begin
                    Dio.Open (Dio_File, Out_File, Package_Filename_Prefix &
                                                     Public_Body_File_Suffix);
                    Dio.Delete (Dio_File);
                exception
                    when Dio.Name_Error =>
                        null;
                end;
            end if; -- Which_Files /= Private_Files

            if Which_Files /= Public_Files then

                -- delete the private_spec_file
                begin
                    Dio.Open (Dio_File, Out_File, Package_Filename_Prefix &
                                                     Private_Spec_File_Suffix);
                    Dio.Delete (Dio_File);
                exception
                    when Dio.Name_Error =>
                        null;
                end;

                -- delete the private_body_file
                begin
                    Dio.Open (Dio_File, Out_File, Package_Filename_Prefix &
                                                     Private_Body_File_Suffix);
                    Dio.Delete (Dio_File);
                exception
                    when Dio.Name_Error =>
                        null;
                end;
            end if; -- Which_Files /= Public_Files

            if Which_Files = All_Files then
                Delete_Internal_Table_Entry (Package_Name);
            end if;

        end if; -- Filename /= No_Filename
    end Delete_Package_Files;

    -----------------------------------------------------------------------------

    procedure Copy_Package_Files (Which_File : in File_Indicator;
                                  Package_Name : in String;
                                  Si_File : in Spo.Paginated_File_Handle) is
        --| Copy the indicated package tracing file into the instrumented
        --| source file.

        Package_Filename_Prefix : Filename_Prefix_String;
        Dio_File : Dio.File_Type;

        File_Start_Index : Dio.Count := 1;
        File_End_Index : Dio.Count;
        Ch : Character;

    begin

        Package_Filename_Prefix := Get_Filename_Prefix (Package_Name);
        case Which_File is
            when Public_Spec =>
                Open (Dio_File, In_File, Package_Filename_Prefix &
                                            Public_Spec_File_Suffix);

            when Public_Body =>
                Open (Dio_File, In_File, Package_Filename_Prefix &
                                            Public_Body_File_Suffix);

            when Private_Spec =>
                Open (Dio_File, In_File, Package_Filename_Prefix &
                                            Private_Spec_File_Suffix);

            when Private_Body =>
                Open (Dio_File, In_File, Package_Filename_Prefix &
                                            Private_Body_File_Suffix);
        end case;

        Spo.Space_Line (Si_File, 1);

        -- while not DIO.end_of_file (DIO_File) loop
        -- Compiler Bug?
        -- When trying to copy the private files, end_of_file is true immediately,
        -- even though the file index = 1, file size > 1, the file exists and
        -- can be read.  So read it explicitly from start to end.

        File_Start_Index := 1;
        File_End_Index := Dio.Size (Dio_File);
        for I in File_Start_Index .. File_End_Index loop
            Dio.Read (Dio_File, Ch);
            if Ch = Ascii.Cr then
                Spo.Put_Line (Si_File, "");
            else
                Spo.Put (Si_File, Ch);
            end if;
        end loop;
        Dio.Close (Dio_File);

    exception
        when others =>
            null;

    end Copy_Package_Files;

    ---------------------------------------------------------

    procedure Save_Spec_With_List (Unit_Name : in String;
                                   With_List : in String_List) is
        --| This procedure is called by the source instrumenter when
        --| a package specification has a with list.  Convert the
        --| string_list to a string_type, and save it so that it
        --| can be retrieved when the package body is found.

        Table_Entry : Table_Entry_Record;
        Found : Boolean;
        List_To_Save : String_Type;
    begin
        Get_Internal_Table_Entry (Unit_Name, Table_Entry, Found);
        if not Found then
            -- make an entry
            Table_Entry.Package_Ada_Name := Make_Persistent (Unit_Name);
        else
            Internal_List_Package.Deleteitem (Internal_Table, Table_Entry);
        end if;

        -- convert the list to a string_type and save it
        Table_Entry.Withed_Units :=
           Make_Persistent (Convert_List_To_String_Type (With_List));
        Attach (Internal_Table, Table_Entry);
        Internal_Table_Changed := True;
    end Save_Spec_With_List;

    ---------------------------------------------------------

    function Get_Spec_With_List (Unit_Name : in String) return String_List is
        --| Retrieve the with_list that was saved for the package
        --| specification, convert it to a string_list, and return
        --| it to the source instrumenter.

        Temp : String_List := String_Lists.Create;
        Table_Entry : Table_Entry_Record;
        Found : Boolean;
    begin
        Get_Internal_Table_Entry (Unit_Name, Table_Entry, Found);
        if Found and then not String_Pkg.Is_Empty
                                 (Table_Entry.Withed_Units) then
            Temp := Convert_String_To_List (Value (Table_Entry.Withed_Units));
        end if;
        return Temp;
    end Get_Spec_With_List;

    -----------------------------------------------------------------------------

    procedure Save_External_File is
        --| Write the internal table list to the extenal file if it has changed.

        Table_Pointer : Internal_List_Package.Listiter;
        Table_Entry : Table_Entry_Record;

    begin
        if Internal_Table_Created and Internal_Table_Changed then
            begin
                Open (External_File, Out_File, External_Filename);
                Reset (External_File);

            exception
                when Text_Io.Name_Error =>
                    Create (External_File, Out_File, External_Filename);
            end;

            Table_Pointer := Makelistiter (Internal_Table);

            while More (Table_Pointer) loop
                Next (Table_Pointer, Table_Entry);

                Put (External_File, Value (Table_Entry.Package_Ada_Name));
                Put (External_File, Terminator);

                Put (External_File, Table_Entry.Package_Filename);
                Put (External_File, Terminator);

                Put (External_File, Value (Table_Entry.Withed_Units));
                Put (External_File, Terminator);

                Put (External_File, Table_Entry.Date_Created);
                Put (External_File, Terminator);

                Put (External_File, Table_Entry.Time_Created);
                Put (External_File, Terminator);
                New_Line (External_File);
            end loop;

            Close (External_File);
            Internal_List_Package.Destroy (Internal_Table);
            Internal_Table_Created := False;
            Internal_Table_Changed := False;
        end if;
    end Save_External_File;

    ---------------------------------------------------------------
    --  External procedures for managing the temporary buffer file.
    ----------------------------------------------------------------

    procedure Initialize is
    begin
        if Dio.Is_Open (Buffer_File) then
            Dio.Reset (Buffer_File);
        else
            Dio.Create (Buffer_File);
        end if;
        Index_Stack := Index_Stack_Pkg.Create;
        Starting_Index := Dio.Index (Buffer_File);
    end Initialize;

    ----------------------------------------------------------------

    procedure Start_New_Section is

    begin
        Index_Stack_Pkg.Push (Index_Stack, Starting_Index);
        Starting_Index := Dio.Index (Buffer_File);
    end Start_New_Section;

    ---------------------------------------------------------------

    procedure Release_Section is

    begin
        Set_Index (Buffer_File, Starting_Index);
        Index_Stack_Pkg.Pop (Index_Stack, Starting_Index);
    end Release_Section;

    ----------------------------------------------------------------

    procedure Writeln_To_Buffer (Dio_File : in Dio.File_Type := Buffer_File;
                                 Line_Of_Text : in String) is

    begin
        for I in Line_Of_Text'First .. Line_Of_Text'Last loop
            Dio.Write (Dio_File, Line_Of_Text (I));
        end loop;

        Dio.Write (Dio_File, Ascii.Cr);
    end Writeln_To_Buffer;

    ----------------------------------------------------------------------

    procedure Save_Buffer_File (Po_File : in Spo.Paginated_File_Handle) is

        Current_Index : Dio.Count;
        Ch : Character;

    begin
        Current_Index := Dio.Index (Buffer_File) - 1;
        if Starting_Index <= Current_Index then
            Spo.Put_Line (Po_File, "");
        end if;

        for I in Starting_Index .. Current_Index loop
            Dio.Read (Buffer_File, Ch, I);
            if Ch = Ascii.Cr then
                Spo.Put_Line (Po_File, "");
            else
                Spo.Put (Po_File, Ch);
            end if;
        end loop;
    end Save_Buffer_File;

    ------------------------------------------------------------------------
    --  Local procedure bodies
    -------------------------------------------------------------------------

    function Table_Equal (X, Y : in Table_Entry_Record) return Boolean is

    begin
        return Equal (X.Package_Ada_Name, Y.Package_Ada_Name) and then
                  X.Package_Filename = Y.Package_Filename and then
                  X.Date_Created = Y.Date_Created and then
                  X.Time_Created = Y.Time_Created;
    end Table_Equal;

    ---------------------------------------------------------

    function Convert_List_To_String_Type
                (L : in String_List) return String_Type is

        --| Iterate through a list of string_types and collect
        --| all of the objects into one string_type, with each
        --| one separated by a blank.

        Iterator : String_Lists.Listiter;
        Next_Object : String_Type;
        Temp : String_Type := No_Name;
        Space : String_Type := Create (" ");
    begin
        Iterator := String_Lists.Makelistiter (L);
        while More (Iterator) loop
            Next (Iterator, Next_Object);
            if Equal (Temp, No_Name) then
                Temp := Next_Object;
            else
                Temp := Temp & Space & Next_Object;
            end if;
        end loop;
        return Temp;
    end Convert_List_To_String_Type;

    ---------------------------------------------------------

    function Convert_String_To_List (S : in String) return String_List is

        --| Make a list of string_types out of a literal string.  Scan
        --| the input string for the next blank, or the end, and create
        --| a string_type object out of it to attach to the list.

        Start : Positive := 1;
        Temp : String_List;

    begin
        Temp := String_Lists.Create;
        for I in S'First .. S'Last + 1 loop
            if (I = S'Last + 1 or else S (I) = ' ') and then Start < I then
                String_Lists.Attach (Temp, Create (S (Start .. I - 1)));
                Start := I + 1;
            end if;
        end loop;
        return Temp;
    end Convert_String_To_List;

    ---------------------------------------------------------

    function Get_Fixed_Length_Table_Entry
                (Length : in Positive) return String is

        --| Read the next LENGTH characters from the external file
        --| and return them as a string.

        Return_String : String (1 .. Length);
        Ch : Character;
        Index : Positive;
    begin
        for I in Return_String'Range loop
            Get (External_File, Ch);
            Return_String (I) := Ch;
        end loop;

        -- read past the terminator
        if Ch /= Terminator then
            Get (External_File, Ch);
        end if;
        return Return_String;
    end Get_Fixed_Length_Table_Entry;

    ---------------------------------------------------------

    function Get_Variable_Length_Table_Entry return String_Type is
        --| Scan the external file until a terminator ('*') is found,
        --| and return a string_type of the characters scanned.

        Return_String : String_Type;
        Ch : Character := ' ';
        Tmp_String : Long_String;
        Index : Natural := 0;
    begin
        Return_String := Create ("");
        while Ch /= Terminator loop
            for I in Long_String'Range loop
                Get (External_File, Ch);
                exit when Ch = Terminator;
                Index := I;
                Tmp_String (Index) := Ch;
            end loop;
            Return_String := Return_String & Create (Tmp_String (1 .. Index));
        end loop;
        return Return_String;
    end Get_Variable_Length_Table_Entry;

    ---------------------------------------------------------

    procedure Create_Internal_Table is
        Table_Entry : Table_Entry_Record;
    begin
        Internal_Table := Internal_List_Package.Create;
        Text_Io.Open (External_File, In_File, External_Filename);

        while not Text_Io.End_Of_File (External_File) loop
            Table_Entry.Package_Ada_Name :=
               Make_Persistent (Get_Variable_Length_Table_Entry);
            Table_Entry.Package_Filename :=
               Get_Fixed_Length_Table_Entry (File_Prefix_Limit);
            Table_Entry.Withed_Units := Make_Persistent
                                           (Get_Variable_Length_Table_Entry);
            Table_Entry.Date_Created :=
               Get_Fixed_Length_Table_Entry (Date_String'Length);
            Table_Entry.Time_Created :=
               Get_Fixed_Length_Table_Entry (Time_String'Length);
            Text_Io.Skip_Line (External_File);
            Attach (Internal_Table, Table_Entry);
        end loop;

        Internal_Table_Created := True;
        Text_Io.Close (External_File);

    exception
        when Text_Io.Name_Error =>
            Internal_Table_Created := True;
    end Create_Internal_Table;

    ---------------------------------------------------------

    function Filename_In_Table
                (Filename : in Filename_Prefix_String) return Boolean is
        --| Search the Internal_Table to see if the filename prefix
        --| string already exists.

        Table_Pointer : Internal_List_Package.Listiter;
        Table_Entry : Table_Entry_Record;

    begin
        Table_Pointer := Internal_List_Package.Makelistiter (Internal_Table);

        while More (Table_Pointer) loop
            Next (Table_Pointer, Table_Entry);
            if Table_Entry.Package_Filename = Filename then
                return True;
            end if;
        end loop;

        return False;

    end Filename_In_Table;

    ---------------------------------------------------------

    function Make_Filename_Prefix (Package_Name : in String)
                                  return Filename_Prefix_String is
        --| Formulate a unique filename prefix for each package name.

        Filename_String : Filename_Prefix_String := (others => 'X');
        --| Name that will be returned

        Findex : Natural := 1;

        subtype A_To_Z is Character range 'A' .. 'Z';

    begin

        -- Loop to extract the first "file_prefix_limit" characters
        -- from the package name to form the prefix of the filename.
        for I in 1 .. Package_Name'Length loop
            if Package_Name (I) /= '_' and Package_Name (I) /= '.' then
                Filename_String (Findex) := Package_Name (I);
                Findex := Findex + 1;
                exit when Findex > File_Prefix_Limit;
            end if;
        end loop;

        --  Now check the Internal_Table to be sure that Filename_String
        --  is unique.  If not, replace successive characters in it from
        --  A to Z until a unique name is found.  This scheme allows
        --  208,827,100,000 unique names.  If this is not sufficient,
        --  digits could also be used for filename characters.

        Main_Loop:
            for I in reverse 1 .. File_Prefix_Limit loop
                for Ch in A_To_Z loop
                    exit Main_Loop when not Filename_In_Table (Filename_String);
                    Filename_String (I) := Ch;
                end loop;
            end loop Main_Loop;

        return Filename_String;

    end Make_Filename_Prefix;

    ---------------------------------------------------------

    procedure Get_Internal_Table_Entry (Package_Name : in String;
                                        Table_Entry : out Table_Entry_Record;
                                        Found : in out Boolean) is

        Iterator : Internal_List_Package.Listiter;
        Next_Entry : Table_Entry_Record;
        Name_To_Match : String_Pkg.String_Type;

    begin
        if not Internal_Table_Created then
            Create_Internal_Table;
        end if;

        String_Pkg.Mark;
        Name_To_Match := Upper (Package_Name);

        -- Initialize the OUT parameters to a Table_Entry_Record with
        -- all fields initialized to null, and false.
        Table_Entry := Next_Entry;
        Found := False;

        Iterator := Internal_List_Package.Makelistiter (Internal_Table);
        while More (Iterator) and not Found loop
            Next (Iterator, Next_Entry);
            if Equal (Next_Entry.Package_Ada_Name, Name_To_Match) then
                -- update the OUT parameters
                Table_Entry := Next_Entry;
                Found := True;
            end if;
        end loop;

        String_Pkg.Release;
    end Get_Internal_Table_Entry;

    ---------------------------------------------------------

    function Start_Package (Package_Name : in String)
                           return Filename_Prefix_String is
        --| Create a table entry for the package and return its unique
        --| filename prefix.  This is called at the start of procedure
        --| Create_Package_Files.

        Entry_Exists : Boolean := False;
        Current_Table_Entry : Table_Entry_Record;
        Current_Date_And_Time : Calendar.Time;
        Current_Date : Date_String;
        Current_Time : String (1 .. 11);

    begin

        --  Check the Internal_Table to see if there is already an
        --  entry for this package.
        Get_Internal_Table_Entry
           (Package_Name, Current_Table_Entry, Entry_Exists);

        if not Entry_Exists then
            Current_Table_Entry.Package_Ada_Name :=
               Make_Persistent (Upper (Package_Name));
            Current_Table_Entry.Package_Filename :=
               Make_Filename_Prefix (Package_Name);
        else
            -- If the table entry exists, then delete it so the
            -- new one can be added with updated date and
            -- time fields.

            Deleteitem (Internal_Table, Current_Table_Entry);

        end if;

        -- Get the date and time that the files are created or updated
        Current_Date_And_Time := Calendar.Clock;
        Current_Date := Date_Of (Calendar.Clock);
        Current_Time := Wall_Clock_Of
                           (Calendar.Seconds (Current_Date_And_Time));

        Current_Table_Entry.Date_Created := Current_Date;
        Current_Table_Entry.Time_Created :=
           Current_Time (1 .. Time_String'Length);

        -- Attach the Current_Table_Entry to the list and set the "changed" flag
        -- so that the external file will be rewritten.

        Attach (Internal_Table, Current_Table_Entry);
        Internal_Table_Changed := True;

        return Current_Table_Entry.Package_Filename;

    end Start_Package;

    ---------------------------------------------------------------------------

    function Get_Filename_Prefix (Package_Name : in String)
                                 return Filename_Prefix_String is
        --| Return the filename prefix for the specified package, or
        --| NO_FILENAME if there isn't an entry for the package.

        Table_Entry : Table_Entry_Record;
        Entry_Exists : Boolean := False;

    begin

        Get_Internal_Table_Entry (Package_Name, Table_Entry, Entry_Exists);

        if not Entry_Exists then
            return No_Filename;
        else
            return Table_Entry.Package_Filename;
        end if;

    end Get_Filename_Prefix;

    -------------------------------------------------------------------------

    procedure Delete_Internal_Table_Entry (Package_Name : in String) is
        --| Delete an entry from the internal table.

        Table_Entry : Table_Entry_Record;
        Entry_Exists : Boolean := False;

    begin

        Get_Internal_Table_Entry (Package_Name, Table_Entry, Entry_Exists);

        if Entry_Exists then
            Deleteitem (Internal_Table, Table_Entry);
            Internal_Table_Changed := True;
        end if;

    end Delete_Internal_Table_Entry;

    ----------------------------------------------------------------------
end Buffer_File_Package;
DataMuseum.dk

Rational R1000/400 Tapes

⟦1c5a9e97a⟧ TextFile

Derivation

TextFile
