Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/help/lart.src

Text File | 1988-05-03 | 31.1 KB | 1,073 lines

::::::::::
load_ar_tape.ada
::::::::::

---------------------------------------------------------------
--        *****************************************          --
--       ***   The Applied Research Laboratory   ***         --
--      ***                 of the                ***        --
--       ***    Pennsylvania State University    ***         --
--        *****************************************          --
---------------------------------------------------------------
--                                                           -*
-- Author       : A. F. Niessner, Jr.
-- Unit Name    : Load_AR_Tape
-- Document     : ARL Internal Memorandum  87-29
-- Version      : 1.0
-- Release Date : February 9, 1987
-- Last Update  : February 9, 1987
--
-- (c)  Copyright 1987 the Pennsylvania State University
--                                                           -*
---------------------------------------------------------------



With Text_Io;                   Use Text_Io;
With Dyn;                       Use Dyn;
With AR_Tape_Io;
With AR_Log_Support;
With AR_Directory_Support;
With AR_System_Dependent;
With Current_Exception;

Procedure Load_AR_Tape is

   Package ti Renames AR_Tape_Io;
   Package ls Renames AR_Log_Support;
   Package ds Renames AR_Directory_Support;
   Package sd Renames AR_System_Dependent;

   Done           : Boolean             := False;
   Correct        : Boolean             := True;
   File_Name      : Dyn_String          := D_string ("");
   Fatal_Error    : Exception;


   Function Restart Return Boolean is

      Answer : Character;

   Begin  --  function Restart

      New_Line (3);
      Put_Line ("   ***   Ada Repository Tape Loading Program   ***");
      New_Line;
      Put_Line ("   ***   Is this a first load Operation or     ***");
      Put_Line ("   ***   is this a restart?                    ***");
      New_Line;
      Put      ("   Enter 'F' for a first load or 'R' for a restart ==> ");
      Loop
         Get (Answer);
         Case Answer is
            When 'f' | 'F' => Put ("irst load");  -- First load
                              New_Line;
                              Return False;
            When 'r' | 'R' => Put ("estart");     -- Restart
                              New_Line;
                              Return True;
            When Others    => Null;
         End Case;
      End Loop;

   End Restart;


   Procedure Load_AR_Directory_File is

      Reference_File : Constant Dyn_String
                     := D_String (sd.Directory_Source_File);

   Begin  --  procedure Load AR Directory File

      While Not Equals (File_Name, Reference_File)
      Loop
         ti.Get_File_Name (File_Name, Done);
         ti.Get_File (ds.Full_Name (File_Name));
         ti.Check_File_Name (File_Name, Correct);
         If Not Correct
         Then ls.Log_Fatal_Error (Str (File_Name));
              Raise Fatal_Error;
         End If;
      End Loop;

   End Load_AR_Directory_File;


Begin   --  procedure Load Ada Repository Tape

   ls.Open_Log_File;

   If Restart
   Then
      ti.Load_Restart_Tape;
      ds.Build_AR_Directory_Array;
   Else
      ti.Initialize_Tape;
      Load_AR_Directory_File;
      ds.Generate_Directory;
   End If;

   Loop
      ti.Get_File_Name (File_Name, Done);
      Exit When Done;
      ti.Get_File (ds.Full_Name (File_Name));
      ti.Check_File_Name (File_Name, Correct);
      If Not Correct
      Then ls.Log_Fatal_Error (Str (File_Name));
           Raise Fatal_Error;
      End If;
   End Loop;

   ls.Close_Log_File;

   Exception
      When Fatal_Error =>
           Text_Io.New_Line (2);
           Text_Io.Put_Line ("Fatal Error Occured on Tape Read");
           Text_Io.Put_Line ("See the AR log file for the problem file");
           Text_Io.New_Line (2);
           ls.Close_Log_file;
      When Others =>
           Text_Io.New_Line (2);
           Text_Io.Put_Line (Current_Exception.Name);
           Text_Io.New_Line (2);
           ls.Close_Log_File;

End Load_AR_Tape;

Pragma Main;
::::::::::
ar_tape_io_sp.ada
::::::::::

With Dyn;                          Use Dyn;

Package AR_Tape_Io is

   Procedure Initialize_Tape;

   Procedure Load_Restart_Tape;

   Function Current_Tape_Record Return Natural;

   Procedure Get_File_Name (File  : Out Dyn_String;
                            Done  : Out Boolean);

   Procedure Get_File (File  : In Dyn_string);

   Procedure Check_File_Name (File    : In Dyn_String;
                              Correct : Out Boolean);

End AR_Tape_Io;

::::::::::
ar_tape_io_b.ada
::::::::::

With Text_Io;                    Use Text_Io;
With AR_Log_Support;
With AR_System_Dependent;
With Current_Exception;

Package Body AR_Tape_Io is


   Package ls Renames AR_Log_Support;
   Package sd Renames AR_System_Dependent;
      Package N_Io is new Integer_Io (Natural);

   Type Tapes is new Natural Range 1..6;

   Record_Count : Natural := 0;
   Errors       : Natural := 0;
   Current_Tape : Tapes   := 1;


   Function Current_Tape_Record Return Natural is

   Begin  --  function Current Tape Record

      Return Record_Count;

   End Current_Tape_Record;


   Procedure Initialize_Tape is

      Answer : Character;

   Begin  --  procedure Initialize Tape

      New_Line (2);
      Put_Line ("   ***  Mount the starting Ada Repository Tape  ***");
      New_Line;
      Put      ("        Then press any character  ===> ");
      Get (Answer);
      New_Line (2);
      Put_Line ("        Loading the starting Ada Repository Tape.");
      New_Line (2);

   End Initialize_Tape;


   Procedure Load_Restart_Tape is

      Starting_Record : Natural := 0;


      Function Tape_Number Return Tapes is

         Header_File  : Text_Io.File_Type;
         Buffer       : String (1..8);

      Begin  --  function Tape Number

         Open  (Header_File, In_File, sd.Tape_Drive & "0");
         Get   (Header_file, Buffer);
         Close (Header_File);
         ls.Log_Tape_Name (Buffer);
         Return Tapes (Character'Pos (Buffer (8)) - Character'Pos ('0'));

      End Tape_Number;


   Begin  --  procedure Load the Restart Tape

      New_Line (2);
      Put ("   What is the starting record number on the tape  ==> ");
      N_Io.Get (Starting_Record);
      New_Line (2);
      Starting_Record := 3 * (Starting_Record / 3);
      Initialize_Tape;
      Current_Tape := Tape_Number;
      Record_Count := Starting_Record;

   End Load_Restart_Tape;


   Procedure Get_Next_Tape (Tape_Available : Out Boolean) is

      Answer     : Character := ' ';
      Afirmative : Boolean;

   Begin  --  procedure Get Next Tape

      New_Line (2);
      Put_Line
      ("   ***  The current Ada Repository tape load is completed.  ***");
      Put_Line
      ("   ***  Please load the next Ada Repository tape.           ***");
      New_Line;
      Put_Line ("   Enter 'y' if a new tape is loaded  -- or --");
      Put      ("   Enter 'n' if all the tapes have been loaded  ===> ");
      Get_Answer:
      Loop
         Get (Answer);
         Case Answer is
            When 'y' | 'Y' => Tape_Available := True;
                              Afirmative     := True;
                              Current_Tape := Current_Tape + 1;
                              Exit Get_Answer;
            When 'n' | 'N' => Tape_Available := False;
                              Afirmative     := False;
                              Exit Get_Answer;
            When Others    => Null;
         End Case;
      End Loop Get_Answer;
      New_Line (2);
      If Afirmative
      Then  --  Give an afirmative response
         Put_Line ("   The tape is now being loaded.");
      Else  --  Give a completion response
         Put_Line ("   The Ada Repository Tape Load is now done.");
      End If;
      New_Line (2);
      Record_Count := 0;

   End Get_Next_Tape;


   Function Extract_Name (x : String) Return Dyn_String is

      --| This function extracts the file name from the input
      --| string and converts any dashes in the name to
      --| underscores.  This conversion is necessary since
      --| AOS/VS does not allow dashes in file names.

      Space : Constant Dyn_String := D_String (" ");
      Work  : Dyn_String := Right (D_String (x), 5);

      Function Dashless (z : Dyn_String) Return Dyn_String is

         Dash        : Constant Dyn_string := D_String ("-");
         Under_Score : Constant Character  := '_';

         Position    : Integer    := 1;
         x           : Dyn_String := z;

      Begin  --  function dashless

         While Position > 0
         Loop
            Position := Index (x, Dash, Position);
            If Position > 0
            Then Substitute (x, Position, Under_Score);
            End If;
         End Loop;
         Return x;

      End Dashless;


   Begin  --  function extract name

      Return Dashless (Substring (Work, 1, Index (Work, Space, 1) - 1));

         --| The substring function removes the characters following
         --| the first space character.

   End Extract_Name;



   Procedure Get_File_Name (File  : Out Dyn_String;
                            Done  : Out Boolean) is

      Header_File  : Text_Io.File_Type;

      Buffer       : Array (1..10) of String (1..80);
      Next         : Natural := 0;
      Another_Tape : Boolean := True;
      Tape_Id      : Array (Tapes) of String (1..14)
                   := ("HDR1ADA1-FILE-",
                       "HDR1ADA2-FILE-",
                       "HDR1ADA3-FILE-",
                       "HDR1ADA4-FILE-",
                       "HDR1ADA5-FILE-",
                       "HDR1ADA6-FILE-");


   Begin  --  procedure get file name

      Done := False;
      Open (Header_File, In_File,
            sd.Tape_Drive & Str (Right (D_String (Record_Count), 2)));
      While not End_of_File (Header_File)
      Loop
         Next := Next + 1;
         Get (Header_file, Buffer (Next));
      End Loop;
      Close (Header_File);
      Record_Count := Record_Count + 1;

      If Buffer (1)(1..14) = Tape_Id (Current_Tape)

         --| This test is needed to check if the file being read
         --| is the file marking the end of the tape.

      Then Get_Next_Tape (Another_Tape);    -- It is the end of tape
           If Another_Tape
           Then Get_File_Name (File, Done);
           Else Done := True;
           End If;
      Else If Next < 3

              --| This test checks for the first record on the tape
              --| which has 3 lines and if it is, then the tape name
              --| is read as well as the file name.

           Then File := Extract_Name (Buffer (1));
           Else File := Extract_Name (Buffer (2));
                ls.Log_Tape_Name (Buffer (1)(1..8));
                   --| The tape name is contained in the first
                   --| eight characters of the first record.
           End If;
      End If;

   End Get_File_Name;


   Procedure Get_File (File : In Dyn_String) is


      Ada_File  : Text_Io.File_Type;
      Source    : Text_Io.File_Type;

      Function Data_Line Return String is

            --| A line in the tape file is stored as a four character
            --| number giving the length of the line including the
            --| four charcaters for the length.

         Blank  : Constant String := " ";

         Buffer : String (1..512);   -- used to store a data line
         Last   : Integer;
         Recved : Integer;
         Size   : String (1..4);     -- used to store the line length

      Begin  --  function data line

         Get (Source, Size);
         If Size (1) > '9'                --| Some lines contain one
         Then Size (1..3) := Size (2..4); --| extra character.  If so
              Get (Source, Size (4));     --| this test pickes up the
         End If;                          --| next number character.
         Last := Int (D_String (Size)) - 4;
         If Last > 0
         Then Get_Line(Source, Buffer (1..Last), Recved);
                 --| Getline is used here since some strange
                 --| characters that abort a get have been
                 --| found in the data.
              Return Buffer (1..Recved);
         Else Return Blank;
         End If;

         Exception
            When End_Error => Return Blank;
            When Others    => --| Several files have a series of ^z's
                              --| at the end.  These create a problem
                              --| with the reading of the file.  This
                              --| exception handler notes the error
                              --| and terminates the file load when
                              --| more than three errors are found in
                              --| a file.
                              ls.Log_Get_File_Error (Str (File),
                                                     Current_Exception.Name);
                              Errors := Errors + 1;
                              Return Blank;

      End Data_Line;


   Begin  --  procedure get file

      Errors := 0;
      Put      ("Getting   ");
      N_Io.Put (Record_Count - 1, 3);
      Put      ("   ");
      Put_Line (Str (File));
      Open   (Source, In_file,
              sd.Tape_Drive & Str (Right (D_String (Record_Count), 2)));
      Create (Ada_File, Out_File, Str (File));
      While not End_of_File (Source)
      Loop
         Put_Line (Ada_File, Data_Line);
         Exit When Errors > 3;
      End Loop;
      Close (Ada_File);
      Close (Source);
      Record_Count := Record_Count + 1;

   End Get_File;


   Procedure Check_File_Name (File    : In Dyn_String;
                              Correct : Out Boolean) is

      Trailer : Text_Io.File_Type;

      Buffer  : Array (1..10) of String (1..80);
      Check   : Dyn_String;
      Next    : Natural      := 0;

   Begin  --  procedure check file name

      Open (Trailer, In_File,
            sd.Tape_Drive & Str (Right (D_String (Record_Count), 2)));
      While not End_of_File (Trailer)
      Loop
         Next := Next + 1;
         Get (Trailer, Buffer (Next));
      End Loop;
      Close (Trailer);
      Record_Count := Record_Count + 1;
      Check := Extract_Name (Buffer (1));
      If Equals (Check, File)
      Then Correct := True;
      Else ls.Log_Check_Error (Str (File), Str (Check));
           Correct := False;
      End If;

   End Check_File_Name;

End AR_Tape_Io;

::::::::::
ar_directory_support_sp.ada
::::::::::

With Dyn;                           Use Dyn;

Package AR_Directory_Support is

   Procedure Build_AR_Directory_Array;

   Procedure Generate_Directory;

   Function Full_Name (Name : In Dyn_String) Return Dyn_String;

End AR_Directory_Support;

::::::::::
ar_directory_support_b.ada
::::::::::

With Text_Io;                   Use Text_Io;
With AR_Log_Support;
With AR_System_Dependent;

Package Body AR_Directory_Support is

   Package ls Renames AR_Log_Support;
   Package sd Renames AR_System_Dependent;

   Blank       : Constant Dyn_String  := D_String ("                ");
   Dir_Length  : Constant             := 1024;

   Type Directory_Record is
      Record
         Dir  : Dyn_String := Blank;
         File : Dyn_String := Blank;
      End Record;

   Type Directory_Pointer is New Natural Range 1..Dir_Length;

   Directory_Array   : Array (Directory_Pointer) of Directory_Record;
   Pointer           : Directory_Pointer := 1;
   Dir_Name          : Dyn_string        := Blank;
   Search            : Directory_Pointer := 10;

   Start             : Boolean           := True;
   Restart           : Boolean           := False;

   Procedure Process (Data : In String) is

      Dir_Header  : Constant Dyn_String := D_String ("PD:<ADA.");
      Tab         : Constant Character  := ASCII.ht;
      Colon       : Constant Dyn_String := D_String (":");

      Work_String : Dyn_String := D_String (Data);


      Function Dashless (z : Dyn_String) Return Dyn_String is

         Dash        : Constant Dyn_string := D_String ("-");
         Under_Score : Constant Character  := '_';

         Position    : Integer    := 1;
         x           : Dyn_String := z;

      Begin  --  function dashless

         While Position > 0
         Loop
            Position := Index (x, Dash, Position);
            If Position > 0
            Then Substitute (x, Position, Under_Score);
            End If;
         End Loop;
         Return x;

      End Dashless;


   Begin  --  procedure process

   If Char (Work_String) /= ' '
   Then
      If Char (Work_String) = Tab  --  it's a file name
      Then Directory_Array (Pointer).File
                           := Dashless (Right (Work_String, 2));
           Directory_Array (Pointer).Dir  := Dir_Name;
           Pointer := Pointer + 1;
      Elsif Str (Substring (Work_String, 1, Length (Dir_Header)))
            = Str (Dir_Header)   --  it's a directory name
      Then Dir_Name := Dashless (Right (Work_String, Length (Dir_Header) + 1));
           Dir_Name := Substring (Dir_Name, 1, Length (Dir_Name) - 1);
           If Not Restart
           Then sd.Make_Directory (sd.Home_Directory & Str (Dir_Name));
           End If;
      Else ls.Log_Directory_Error (Str (Dir_Name), Data);
      End If;
   End If;

   End Process;


   Procedure Build_AR_Directory_Array is

   Begin  --  procedure Build AR Directory Array

      Restart := True;
      Start   := False;      --| Set so that initial file name
                             --| search in function full_name
                             --| will not be made.
      Search  := Dir_Length  --| Sets the search for a file name
               - Pointer;    --| in function full_name to the
                             --| length of the directory array.
      Generate_Directory;

   End Build_AR_Directory_Array;


   Procedure Generate_Directory is

      Header_Lines : Constant := 4;

      Source       : Text_Io.File_Type;
      Buffer       : String (1..132);
      Last         : Integer;

   Begin  --  procedure Generate Directory

      Open (Source, In_File, sd.Directory_Source);

      For i in 1..Header_Lines             --| Remove the header
      Loop                                 --| lines from the top
         Get_Line (Source, Buffer, Last);  --| of the Ada.crclst
      End Loop;                            --| file.

      While not End_of_File (Source)
      Loop
         Get_Line (Source, Buffer, Last);
         Process  (Buffer (1..Last));
      End Loop;

      Close (Source);
      Pointer := 1;

   End Generate_Directory;


   Function Full_Name (Name : In Dyn_String) Return Dyn_String is

      Colon : Constant Dyn_String := D_String (":");

      Dir   : Dyn_String := Directory_Array (Pointer).Dir & Colon;
      Next  : Dyn_String := Directory_Array (Pointer).File;

   Begin  --  function Full Name

      Next := Substring (Next, 1, Length (Name));

      If Start

         --| This code provides the sync between the tape files
         --| and the directory array list of files.

      Then If Equals (Name, Next)
           Then Start := False;
                ls.Log_File_Name (sd.Home_Directory & Str (Dir & Name));
                Pointer := Pointer + 1;
                Return D_String (sd.Home_Directory) & Dir & Name;
           Else ls.Log_File_Name (sd.Home_Directory & Str (Name));
                Return D_String (sd.Home_Directory) & Name;
           End If;
      End If;

      If Equals (Name, Next)
      Then ls.Log_File_Name (sd.Home_Directory & Str (Dir & Name));
           Pointer := Pointer + 1;
           Return D_String (sd.Home_Directory) & Dir & Name;
      Else For i in (Pointer + 1)..(Pointer + Search)
           Loop
              Dir  := Directory_Array (i).Dir & Colon;
              Next := Directory_Array (i).File;
              Next := Substring (Next, 1, Length (Name));
              If Equals (Name, Next)
              Then Pointer := i + 1;
                   Search  := 10;
                   ls.Log_File_Name (sd.Home_Directory & Str (Dir & Name));
                   Return D_String (sd.Home_Directory) & Dir & Name;
              End If;
           End Loop;
           ls.Log_File_Name ((sd.Home_Directory & Str (Name)), True);
           Return D_String (sd.Home_Directory) & Name;
       End If;

   End Full_Name;


End AR_Directory_Support;

::::::::::
ar_log_support_sp.ada
::::::::::

Package AR_Log_Support is

   Procedure Open_Log_File;

   Procedure Log_Tape_Name (Tape : In String);

   Procedure Log_File_Name (File  : In String;
                            Check : In Boolean := False);

   Procedure Log_Check_Error (File_Name  : In String;
                              Check_Name : In String);

   Procedure Log_Get_File_Error (File_Name : In String;
                                 Error     : In String);

   Procedure Log_Directory_Error (Directory  : In String;
                                  Error_Line : In String);

   Procedure Log_Fatal_Error (File : In String);

   Procedure Close_Log_File;

End AR_Log_Support;


::::::::::
ar_log_support_b.ada
::::::::::

With AR_System_Dependent;
With AR_Tape_Io;
With Calendar;
With Text_Io;                     Use Text_Io;

Package Body AR_Log_Support is

      Log_File      : Text_Io.File_Type;

   Package N_Io is new Text_Io.Integer_Io (Natural);
   Use N_Io;

   Package ti Renames AR_Tape_Io;
   Package sd Renames AR_System_Dependent;


   Procedure Open_Log_File is

      Title  : Constant String :=
"               Ada Repository Tape Load Log File";
      Header : Constant String :=
"  File No.  Full Path File Name                           File Check";

      Procedure Put_The_Date is

         Slash : Constant Character := '/';

         Use Calendar;

      Begin  --  procedure Put the Data

         Put (Log_File, Month (Clock), 2);
         Put (Log_File, Slash);
         Put (Log_File, Day (Clock), 2);
         Put (Log_File, Slash);
         Put (Log_File, Year (Clock) - 1900, 2);

      End Put_the_Date;


   Begin  --  procedure Open Log File

      Create   (Log_File, Out_File, sd.Log_File_Name);
      New_Line (Log_File, 2);
      Put_Line (Log_File, Title);
      New_Line (Log_File);
      Put      (Log_File, "                                  Date: ");
      Put_the_Date;
      New_Line (Log_File, 2);
      Put_Line (Log_File, Header);

   End Open_Log_File;


   Procedure Log_Tape_Name (Tape : In String) is

   Begin  --  procedure Log Tape Name

      New_Line (Log_File);
      Put      (Log_File, "The Tape Name is: ");
      Put_Line (Log_File, Tape);
      New_Line (Log_File);

   End Log_Tape_Name;


   Procedure Log_File_Name (File  : In String;
                            Check : In Boolean := False) is

      Number_Size  : Constant         := 9;
      Check_Column : Constant Integer := 60;
      Check_Ident  : Constant String  := "**********";

   Begin  --  procedure Log File Name

      Put      (Log_File, ti.Current_Tape_Record - 1, Number_Size);
      Put      (Log_File, "    ");
      Put      (Log_File, File);
      If Check
      Then For i in 1..(Check_Column - (Number_Size + 4 + File'Length))
           Loop
              Put (Log_File, " ");
           End Loop;
           Put (Log_File, Check_Ident);
      End If;
      New_Line (Log_File);

   End Log_File_Name;


   Procedure Log_Check_Error (File_Name  : In String;
                              Check_Name : In String) is

   Begin  --  procedure Log Check Error

      New_Line (Log_File, 2);
      Put      (Log_File, "In Tape Record Number ==> ");
      Put      (Log_File, (ti.Current_Tape_Record - 1), 6);
      New_Line (Log_File);
      Put      (Log_File, "The Check File Name   ==> ");
      Put_Line (Log_File, Check_Name);
      Put      (Log_File, "Did Not Agree With    ==> ");
      Put_Line (Log_File, File_Name);
      New_Line (Log_File, 2);

   End Log_Check_Error;


   Procedure Log_Get_File_Error (File_Name : In String;
                                 Error     : In String) is

   Begin  --  procedure Log Get File Error

      New_Line (Log_File, 2);
      Put      (Log_File, "The Following Exception was raised during ");
      Put_Line (Log_File, "a Get File");
      Put      (Log_File, "of the file ");
      Put_Line (Log_File, File_Name);
      Put_Line (Log_File, Error);
      Put      (Log_File, "In Tape Record Number ");
      Put      (Log_File, ti.Current_Tape_Record, 6);
      New_Line (Log_File, 3);

   End Log_Get_File_Error;


   Procedure Log_Directory_Error (Directory  : In String;
                                  Error_Line : In String) is

   Begin  --  procedure Log Directory Error

      New_Line (Log_File, 2);
      Put      (Log_File, "The following incorrect line was read ");
      Put_Line (Log_File, "during Directory Generation");
      Put      (Log_File, "of directory ");
      Put_Line (Log_File, Directory);
      Put_Line (Log_File, Error_Line);
      New_Line (Log_File, 2);

   End Log_Directory_Error;


   Procedure Log_Fatal_Error (File : In String) is

   Begin  --  procedure Log Fatal Error

      New_Line (Log_File);
      Put      (Log_File, "The AR Tape Load has been halted due to a ");
      Put      (Log_File, "Name Check Error");
      New_Line (Log_File);
      Put      (Log_File, "While loading file ");
      Put_Line (Log_File, File);
      Put      (Log_File, "At Tape Record Number ==> ");
      Put      (Log_File, ti.Current_Tape_Record, 6);
      New_Line (Log_File, 2);

   End Log_Fatal_Error;


   Procedure Close_Log_File is

      Ending : Constant String := "End of the Log File data.";

   Begin  --  procedure Close Log File

      New_Line (Log_File, 3);
      Put_Line (Log_File, Ending);
      New_Line (Log_File, 2);
      Close    (Log_File);

   End Close_Log_File;


End AR_Log_Support;

::::::::::
ar_system_dependent_sp.ada
::::::::::

Package AR_System_Dependent is

   Function Log_File_Name Return String;

   Function Tape_Drive Return String;

   Function Home_Directory Return String;

   Function Directory_Source Return String;

   Function Directory_Source_File Return String;

   Procedure Make_Directory (Directory_Name : In String);

End AR_System_Dependent;

::::::::::
ar_system_dependent_b.ada
::::::::::

With Sys_Calls;           --| These packages are used by the
With String_Conversion;   --| procedure Make_Directory.
With Bit_Ops;             --|

Package Body AR_System_Dependent is


   --| The following names should be changed to match the installation
   --| of the Ada Repository on your system.  The functions in this
   --| package return these names to the program when needed.

   Log_Name         : Constant String := "AR_Tape_Load.Log";

      --| This is the name of the file which will contain the list
      --| of files loaded from the Ada repository tape, the number
      --| of the file on the tape, and the directory in which the
      --| file was written.

   Tape_Drive_Name  : Constant String := "@mtb0:";

      --| Tape drive is the name system name used to read from the
      --| magnetic tape containing the Ada repository files.

   AR_Directory     : Constant String := ":disk2:ada_repository:";

      --| AR directory is the pathname to the home directory where
      --| the Ada repository subdirectories will be created.

   Directory_File   : Constant String := "ADA.CRCLST";

      --| The Ada.Crclst file should not be changed since the directory
      --| extraction procedures in the package AR_Directory_Support
      --| are written for the data as formatted in Ada.Crclst.
      --|
      --| Directory file is the name of the file from the Ada repository
      --| tape that will be used to extract the Ada repository subdirectory
      --| structure.  This file is read from the first Ada repository
      --| tape and used to create the proper subdirectories for storing
      --| the Ada repository files.



   Function Log_File_Name Return String is
   Begin  --  function Log File Name
      Return Log_Name;
   End Log_File_Name;


   Function Tape_Drive Return String is
   Begin  --  function Tape Drive
      Return Tape_Drive_Name;
   End Tape_Drive;


   Function Home_Directory Return String is
   Begin  --  function Home Directory
      Return AR_Directory;
   End Home_Directory;


   Function Directory_Source Return String is
   Begin  --  function Directory Source
      Return AR_Directory & Directory_File;
   End Directory_Source;


   Function Directory_Source_File Return String is
   Begin  --  function Directory Source File
      Return Directory_File;
   End Directory_Source_File;


   --| The following procedure has been written to create subdirectories
   --| for storing the Ada repository data with the same subdirectory
   --| structure as the Ada Repository on Simtel20.  This procedure is
   --| system dependent since it uses the Data General AOS/VS System
   --| calls package.

Procedure Make_Directory (Directory_Name : In String) is

   Use String_Conversion;
   Use Sys_Calls;

   Record_Format       :Integer  :=  0;  -- These three go
   Dir_File_Type       :Integer  := 10;  -- towards making
   Hash_Frame          :Integer  :=  0;  -- up word1

   Time_Address        :Integer  := -1;  -- word2
   Access_Control_List :Integer  := -1;  -- word3
   Control_P_Dir       :Integer  :=  0;  -- word4

   Max_Index_Level     :Integer  :=  3;  -- These two go
   Reserved            :Integer  :=  0;  -- towards making
                                         -- up word5

   Type Create_Packet is
      Record
         Word1 :Integer := Record_Format * 2**24
                         + Dir_File_Type * 2**16 + Hash_Frame;
         Word2 :Integer := Time_Address;
         Word3 :Integer := Access_Control_List;
         Word4 :Integer := Control_P_Dir;
         Word5 :Integer := Max_Index_Level * 2**16 + Reserved;
      End Record;

   Packet            : Create_Packet;
   Unchanged         : Integer;
   Undefined         : Integer;
   Pathname          : Packed_String(1..40);
   Address           : Integer;
   Cerror            : Error_Code;

Begin  --  procedure Make Directory

   Pack_String ((Directory_Name & Ascii.Nul), Pathname);
   Address := Bit_Ops.Left_Shift (Integer (Pathname (1)'Address),1);
   Sys (Create,
        In_AC0  => Address,
        In_AC1  => 0,
        In_AC2  => Integer (Packet'Address),
        Out_AC0 => Unchanged,
        Out_AC1 => Undefined,
        Out_AC2 => Unchanged,
        Error   => Cerror);

End Make_Directory;


End AR_System_Dependent;

::::::::::
compile_lart.cli
::::::::::

Ada AR_System_Dependent_sp.ada
Ada AR_Log_Support_sp.ada
Ada AR_Directory_Support_sp.ada
Ada AR_Tape_Io_sp.ada
Ada Load_AR_Tape.ada
Ada AR_System_Dependent_b.ada
Ada AR_Log_Support_b.ada
Ada AR_Directory_Support_b.ada
Ada AR_Tape_Io_b.ada
Adalink/mtop=2 Load_AR_Tape