|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 13917 (0x365d)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦591c5b094⟧
└─⟦this⟧
with Ada;
with Common;
with Compilation;
with Debug_Tools;
with Directory_Tools;
with Editor;
with Io;
with Library;
with Log;
with Profile;
with Time_Utilities;
with Ada_Parameterization;
procedure Parameterize_Ada_Unit (Unit : String := "@'c(Ada)";
Parms : String := "";
Repromote : Boolean := False;
Response : String := "<PROFILE>") is
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the name of Rational not be used in
-- advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- Rational disclaims all warranties with regard to this software, including
-- all implied warranties of merchantability and fitness, in no event shall
-- Rational be liable for any special, indirect or consequential damages or
-- any damages whatsoever resulting from loss of use, data or profits, whether
-- in an action of contract, negligence or other tortious action, arising out
-- of or in connection with the use or performance of this software.
------------------------------------------------------------------------------
package Naming renames Directory_Tools.Naming;
package Object renames Directory_Tools.Object;
Response_Profile : Profile.Response_Profile := Profile.Value (Response);
Quit : exception; -- Raised when we want to terminate.
-- Total_Parms : constant String :=
-- "" -- These all apply for R1000's
-- & "DEBUG,"
--
-- & "R1000,"
-- & "R1000_SIZE_BUG,"
--
-- & "MULTITASK_LOCKING,"
--
-- & "ENABLE_DEALLOCATION,"
-- & "LENGTH_CLAUSES,"
-- & "RECORD_REP_CLAUSES => FALSE,"
--
-- & "BIT0_SIGN_BIT => TRUE, "
-- & "BYTE0_SIGN_BYTE => TRUE, "
-- & "RECORD_REP_STORAGE_UNIT_8 => TRUE, "
-- & "POSITIVE_IS_LARGE => TRUE, "
-- & "RAW_IS_UNSIGNED => TRUE, "
-- & "ROW_MAJOR_ORDER => TRUE, "
--
-- & Parms;
Temp_File_Name : constant String :=
"!Machine.Temporary.Parameterize_Ada_Unit_" &
Time_Utilities.Image (Time_Utilities.Get_Time,
Date_Style => Time_Utilities.Ada,
Contents => Time_Utilities.Date_Only) &
"_" &
Time_Utilities.Image (Time_Utilities.Get_Time,
Time_Style => Time_Utilities.Ada,
Contents => Time_Utilities.Time_Only);
Temp_File : Io.File_Type;
--\f
function Replace_Old_File (Input : String;
Output : String) return Boolean is
------------------------------------------------------------------------------
-- Input - Specifies the name of our temporary file
-- Output - Specifies the name of our output file.
--
-- We compare the contents of the Output file to the contents of the Input
-- file. If they are identical then we return False. If they are different
-- then we return True.
------------------------------------------------------------------------------
use Io;
Inp_File : File_Type;
Out_File : File_Type;
Inp_Line : String (1 .. 1024);
Out_Line : String (1 .. 1024);
Inp_Len : Natural;
Out_Len : Natural;
Lno : Positive_Count := 1;
Pno : Positive_Count := 1;
Eof : Boolean := False;
Eop : Boolean := False;
Eol : Boolean := False;
St_I : Natural;
St_O : Natural;
Fi_I : Natural;
Fi_O : Natural;
begin
----Open the files for reading.
Open (Inp_File, In_File, Input);
Open (Out_File, In_File, Output);
----Read them a line at a time. If we hit eof on both then they are the same.
begin
loop
if End_Of_File (Inp_File) and then End_Of_File (Out_File) then
Close (Inp_File);
Close (Out_File);
return False;
end if;
----Read a line. Strip off leading and trailing blanks.
Get_Line (Inp_File, Inp_Line, Inp_Len);
St_I := 1;
for I in 1 .. Inp_Len loop
if Inp_Line (I) = ' ' or else
Inp_Line (I) = Ascii.Ht then
St_I := I + 1;
else
exit;
end if;
end loop;
Fi_I := Inp_Len;
for I in reverse St_I .. Inp_Len loop
if Inp_Line (I) = ' ' or else
Inp_Line (I) = Ascii.Ht then
Fi_I := I - 1;
else
exit;
end if;
end loop;
----Read a line. Strip off leading and trailing blanks.
Get_Line (Out_File, Out_Line, Out_Len);
St_O := 1;
for I in 1 .. Out_Len loop
if Out_Line (I) = ' ' or else
Out_Line (I) = Ascii.Ht then
St_O := I + 1;
else
exit;
end if;
end loop;
Fi_O := Out_Len;
for I in reverse St_O .. Out_Len loop
if Out_Line (I) = ' ' or else
Out_Line (I) = Ascii.Ht then
Fi_O := I - 1;
else
exit;
end if;
end loop;
----Are the two stripped lines the same?
if Page (Inp_File) /= Page (Out_File) or else
Fi_I - St_I /= Fi_O - St_O or else
Inp_Line (St_I .. Fi_I) /= Out_Line (St_O .. Fi_O) then
exit;
end if;
end loop;
----Early eof on one file means they differ.
exception
when End_Error =>
null;
end;
----The files differ, close them and return.
Close (Inp_File);
Close (Out_File);
return True;
end Replace_Old_File;
--\f
procedure Process_Unit (Unit : String) is
------------------------------------------------------------------------------
-- Unit - Specifies the full path name of an Ada unit that we are to process
--
-- Called to process a specific unit.
------------------------------------------------------------------------------
begin
----Announce our intentions.
Log.Put_Line ("Process " & Unit,
Profile.Positive_Msg,
Response_Profile);
----Process the file and turn on/off any parameterizations.
Ada_Parameterization.Process_File (Unit, Temp_File_Name);
if Replace_Old_File (Unit, Temp_File_Name) then
----Now reduce the source file to Source.
Compilation.Demote (Unit => Unit,
Goal => Compilation.Source,
Limit => "<ALL_WORLDS>",
Effort_Only => False,
Response => Response);
----Now parse the temp file and replace the original Ada file.
declare
Old_Version : constant String :=
Directory_Tools.Naming.Version_Attribute
(Directory_Tools.Naming.Unique_Full_Name
(Directory_Tools.Naming.Resolution (Unit)));
begin
Compilation.Parse
(File_Name => Temp_File_Name,
Directory => Naming.Prefix (Unit) & ".$",
List => False,
Source_Options => "",
Response => Response);
----Silly damn Compilation does not RAISE on errors. Arghhh...
-- See if the version number changed.
if Old_Version =
Directory_Tools.Naming.Version_Attribute
(Directory_Tools.Naming.Unique_Full_Name
(Directory_Tools.Naming.Resolution (Unit))) then
if Profile.Propagate (Response_Profile) then
raise Library.Error;
end if;
end if;
end;
----Silly R1000 parser bug; it throws away all form-feeds. Go put them
-- back into the image.
Editor.Mark.Push (Repeat => 1);
Common.Edit (Name => Unit,
In_Place => False,
Visible => True);
Editor.Image.Beginning_Of (Offset => 0);
Editor.Search.Replace_Next (Target => "<!E" & "OP!>",
Replacement => (1 => Ascii.Ff),
Repeat => 99999,
Wildcard => False);
Ada.Source_Unit;
Common.Release (Window => "<IMAGE>");
Editor.Mark.Top;
Editor.Mark.Delete_Top;
end if;
end Process_Unit;
--\f
function No_Version (Name : String) return String is
------------------------------------------------------------------------------
-- Remove the 'V(xxx) version attribute from a name.
------------------------------------------------------------------------------
begin
for I in reverse Name'Range loop
if Name (I) = ''' and then
I <= Name'Last - 4 and then
Name (I .. I + 2) = "'V(" then
for J in I + 3 .. Name'Last loop
if Name (J) = ')' then
if J = Name'Last then
return Name (Name'First .. I - 1);
else
return Name (Name'First .. I - 1) &
Name (J + 1 .. Name'Last);
end if;
end if;
end loop;
end if;
end loop;
end No_Version;
--\f
procedure Main_Line is
------------------------------------------------------------------------------
-- Called to control the performance of the actual work. We resolve the
-- possibly wildcarded Ada unit name specification and then we process each
-- of the named units one at a time.
------------------------------------------------------------------------------
Unit_Iter : Object.Iterator;
Unit_Object : Object.Handle;
begin
----Announce our presence.
Log.Put_Line ("[Parameterize_Ada_Unit (" & Unit & ")]",
Profile.Note_Msg,
Response_Profile);
----See if there are any Units to process.
Unit_Iter := Naming.Resolution ("[" & Unit & "]'c(ada)");
if Object.Done (Unit_Iter) then
Log.Put_Line (Unit & " does not match any existing Ada units.",
Profile.Error_Msg,
Response_Profile);
raise Quit;
end if;
----Process each Unit.
loop
Unit_Object := Object.Value (Unit_Iter);
declare
Name : constant String :=
No_Version (Naming.Unique_Full_Name (Unit_Object));
begin
Process_Unit (Name);
end;
----Get the next unit.
Object.Next (Unit_Iter);
if Object.Done (Unit_Iter) then
exit;
end if;
end loop;
----Now put all units back to Installed.
if Repromote then
Compilation.Promote (Unit => Unit,
Scope => Compilation.Subunits_Too,
Goal => Compilation.Installed,
Limit => "<WORLDS>",
Effort_Only => False,
Response => Response);
end if;
----Delete the temp file.
Compilation.Delete (Unit => Temp_File_Name,
Limit => "<WORLDS>",
Response => Response & " ~:::");
----We are all done.
Log.Put_Line ("[End Parameterize_Ada_Unit]",
Profile.Note_Msg,
Response_Profile);
return;
end Main_Line;
--\f
------------------------------------------------------------------------------
-- Process the Units and catch all exceptions that may fly out.
------------------------------------------------------------------------------
begin
Ada_Parameterization.Parameter_Definition (Parms);
Main_Line;
exception
when Quit | Library.Error =>
Log.Put_Line ("[End Parameterize_Ada_Unit]",
Profile.Note_Msg,
Response_Profile);
raise Library.Error;
when others =>
Log.Put_Line ("Unexpected exception: " &
Debug_Tools.Get_Exception_Name (True, True),
Profile.Exception_Msg,
Response_Profile);
raise;
end Parameterize_Ada_Unit;