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: 32618 (0x7f6a) Types: TextFile Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00 └─ ⟦0c20f784e⟧ »DATA« └─⟦1abbe589f⟧ └─⟦591c5b094⟧ └─⟦this⟧
with Error_Report; use Error_Report; with Lexemes; use Lexemes; with Symbol_Table; with Text_Io; with Arithmetic; use Arithmetic; with Vstring_Assign; use Vstring_Assign; with Vstring_Heap; use Vstring_Heap; with Vstring_Io; with Vstring_Query; use Vstring_Query; with Vstring_Scan; use Vstring_Scan; with Vstring_Type; use Vstring_Type; package body Ada_Parameterization is ------------------------------------------------------------------------------ -- Copyright 1989 - 1990 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. ------------------------------------------------------------------------------ -- **************************************************************************** -- * Date - /Name/ Comment -- * -- * 27-NOV-90 - /GEB/ Add the Normalize option to Process_File. -- * 13-FEB-91 - /GEB/ Modify for the new E_String/VString changes. -- **************************************************************************** ------------------------------------------------------------------------------ -- Input/Output ------------------------------------------------------------------------------ Orig_Line : Vstring := New_Vstring (512); Orig_Eop : Boolean; Cur_Line : Vstring := New_Vstring (512); Cur_Line_No : S_Natural := 0; On_R1000 : Boolean := False; ------------------------------------------------------------------------------ -- Lexing Controls ------------------------------------------------------------------------------ Cur_Indent : S_Natural; Cur_Lexeme : Lexeme_Kind := Lk_Error; Cur_Text : Vstring := New_Vstring (64); Cur_Value : Symbol_Value; Expr_Value : Symbol_Value; Skip_Whitespace : Breakset; -- skip blanks ------------------------------------------------------------------------------ -- Expression Controls ------------------------------------------------------------------------------ type Operator_Flag_Array is array (Lexeme_Kind) of Boolean; Binary_Operator : constant Operator_Flag_Array := Operator_Flag_Array' (Lk_And | Lk_Or | Lk_Xor => True, -- Boolean ops others => False); type Operator_Precedence_Array is array (Lexeme_Kind) of Natural; Operator_Precedence : constant Operator_Precedence_Array := Operator_Precedence_Array' (Lk_And => 1, Lk_Or => 1, Lk_Xor => 1, -- lk_eql => 2, -- lk_neq => 2, -- lk_gtr => 2, -- lk_lss => 2, -- lk_geq => 2, -- lk_leq => 2, -- lk_plus => 3, -- lk_minus => 3, -- lk_append => 3, -- lk_times => 5, -- lk_divide => 5, -- lk_mod => 5, -- lk_rem => 5, -- lk_power => 6, others => 0); Normalizing : Boolean := False; ------------------------------------------------------------------------------ -- Forward Procedure Declarations ------------------------------------------------------------------------------ procedure Handle_Control (In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type; Cur_Hide_State : Boolean); function Parse_Expression (In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type) return Boolean; --\f procedure Error1 (Line1 : String) is ------------------------------------------------------------------------------ -- Line1 - Specifies the first text line of an error message -- -- Called to put out a "one line" error message in standard form. ------------------------------------------------------------------------------ begin Error ("Line:" & S_Natural'Image (Cur_Line_No)); Error (Line1); end Error1; --\f procedure Error2 (Line1 : String; Line2 : String) is ------------------------------------------------------------------------------ -- Line1 - Specifies the first text line of an error message -- Line1 - Specifies the second text line of an error message -- -- Called to put out a "two line" error message in standard form. ------------------------------------------------------------------------------ begin Error ("Line:" & S_Natural'Image (Cur_Line_No)); Error (Line1); Error (Line2); end Error2; --\f function Chop3 (Str : String) return String is ------------------------------------------------------------------------------ -- Str - Specifies the string to chop -- -- Remove the first 3 characters from the argument. ------------------------------------------------------------------------------ begin return Str (Str'First + 3 .. Str'Last); end Chop3; --\f function Next_Line (In_File : Text_Io.File_Type) return Boolean is ------------------------------------------------------------------------------ -- Called to fill Cur_Line/Orig_Line with the next line from the input. -- Returns TRUE on final End-of-File. ------------------------------------------------------------------------------ Eol : Boolean; Eop : Boolean; Eof : Boolean; begin ----Get the next input line. Cur_Line_No := Cur_Line_No + 1; Vstring_Io.Get_Resize (In_File, Orig_Line, 256, Eol, Eop, Eof); ---If we got nothing and if we have EOF then we are done. if Orig_Line.Length = 0 and then Eof then return True; end if; ----If we have end-of-page then put a form-feed on the end of the line. Orig_Eop := Eop and then not Eof; ----Copy the line into the Cur_Line temporary buffer and return. Cur_Line.Length := 0; Append_Resize (Cur_Line, Orig_Line, 256); ----In an attempt to get the R1000 parser to stop re-pretty-printing everything -- (and thus making DIFF's harder than they need to be), add two blanks to -- the end of every line that doesn't already have them. if Cur_Line.Length >= 2 and then not Orig_Eop and then Cur_Line.Chars (Cur_Line.Length - 1 .. Cur_Line.Length) /= " " then Append_Resize (Orig_Line, " ", 256); Append_Resize (Cur_Line, " ", 256); end if; return False; end Next_Line; --\f procedure Output_Line (Out_File : Text_Io.File_Type; Line : Vstring) is ------------------------------------------------------------------------------ -- Out_File - Specifies the output file to use -- Line - Specifies the complete line that is to be put out -- -- After Orig_Line has been "processed" we replace it in the output with -- this Line. We use Orig_Eop in an attempt to keep form-feeds (page marks) -- from "sliding around". This is very important on R1000's as a form-feed -- that isn't in a comment will be lost forever when the *&^$%*&^$ pretty- -- printer gets done with it. ------------------------------------------------------------------------------ begin if not Orig_Eop then Vstring_Io.Put_Line (Out_File, Line); else Vstring_Io.Put (Out_File, Line); if On_R1000 then declare I : S_Natural := 1; begin while I <= Line.Length loop if Line.Chars (I) = '-' then if I < Line.Length and then Line.Chars (I + 1) = '-' then exit; end if; elsif Line.Chars (I) = '"' then I := I + 1; while I <= Line.Length and then Line.Chars (I) /= '"' loop I := I + 1; end loop; end if; I := I + 1; end loop; if I > Line.Length then Text_Io.Put (Out_File, "--"); end if; end; Text_Io.Put (Out_File, "<!EOP!>"); end if; Text_Io.Put (Out_File, Ascii.Ff); end if; end Output_Line; --\f function Cur_Line_Controls return S_Natural is ------------------------------------------------------------------------------ -- Called to see if Cur_Line begins with --/ or maybe --//. We return 2 for -- --//, 1 for --/, and 0 for anything else. ------------------------------------------------------------------------------ Brk : Character; begin ----Skip any whitespace. Trunc_Scan (Cur_Line, Skip_Whitespace, Brk); ----If no "--/" at the beginning then return 0. if Brk /= '-' or else Cur_Line.Length < 3 or else Cur_Line.Chars (2) /= '-' or else Cur_Line.Chars (3) /= '/' then return 0; end if; -----If not "--//" then return 1 after removing the "--/". if Cur_Line.Length < 4 or else Cur_Line.Chars (4) /= '/' then Cur_Indent := Orig_Line.Length - Cur_Line.Length; Truncstring_For (Cur_Line, 4, Inf); return 1; end if; ----Remove the "--//" or the "--// " and return 2. if Cur_Line.Length > 4 and then Cur_Line.Chars (5) = ' ' then Truncstring_For (Cur_Line, 6, Inf); else Truncstring_For (Cur_Line, 5, Inf); end if; return 2; end Cur_Line_Controls; --\f function Next_Token (In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type; Want_Eol : Boolean) return Lexeme_Kind is ------------------------------------------------------------------------------ -- Called when we *must* read the Cur_Line (or a following Next_Line) and -- obtain another lexeme value. If there isn't one or if we hit end-of-file -- then we return Lk_Error. We also set up Cur_Lexeme and Cur_Text. ------------------------------------------------------------------------------ begin loop Next_Lexeme (Cur_Line, Cur_Lexeme, Cur_Text, Cur_Value); if Want_Eol or else Cur_Lexeme /= Lk_Eol then return Cur_Lexeme; end if; if Next_Line (In_File) then Error1 ("Ran into End-of-File while reading control tokens."); Cur_Lexeme := Lk_Error; return Lk_Error; end if; Output_Line (Out_File, Orig_Line); if Cur_Line_Controls /= 1 then Error1 ("This line is not a control line continuation of " & "previous line."); Cur_Lexeme := Lk_Error; return Lk_Error; end if; end loop; end Next_Token; --\f function Parse_Primary (In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type) return Boolean is ------------------------------------------------------------------------------ -- Called to parse a "primary" expression. eg. a single name, single constant, -- unary operators with primary arguments, and () nested expressions. -- The expression value is returned in Cur_Value. -- Returns TRUE if we hit an error. ------------------------------------------------------------------------------ begin ----Dispatch based upon the kind of lexeme we are dealing with. case Cur_Lexeme is ----Id's are done as-is. when Lk_Identifier => Expr_Value := Cur_Value; Cur_Lexeme := Next_Token (In_File, Out_File, Want_Eol => False); return False; ----Unary operators. when Lk_Not => Cur_Lexeme := Next_Token (In_File, Out_File, Want_Eol => False); if Parse_Primary (In_File, Out_File) then return True; end if; if Expr_Value.Kind /= Sk_Boolean then Error1 ("Argument to NOT operator was not a boolean value?"); return True; end if; Expr_Value.Bool := not Expr_Value.Bool; return False; ----Embedded expressions. when Lk_Lparen => Cur_Lexeme := Next_Token (In_File, Out_File, Want_Eol => False); if Parse_Expression (In_File, Out_File) then return True; end if; Cur_Lexeme := Next_Token (In_File, Out_File, Want_Eol => False); return False; ----Anything else is a problem. when others => Error2 ("Found unexpected lexeme while parsing expression.", "Lexeme kind: " & Chop3 (Lexeme_Kind'Image (Cur_Lexeme)) & " {" & String (Substring_To (Cur_Text, 1, 512)) & "}"); Cur_Lexeme := Lk_Identifier; Expr_Value := (Kind => Sk_Boolean, Permanent => False, Bool => False); return False; end case; end Parse_Primary; --\f function Parse_Secondary (In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type; Bin_Op : Lexeme_Kind) return Boolean is ------------------------------------------------------------------------------ -- In_File - Specifies the file to read for more input -- Bin_Op - Specifies the binary operator we are evaluating -- -- Called to parse a "secondary" expression. The first argument has been -- done already as has the binary operator. It is up to us to evaluate the -- second expression and then apply the operator. -- The expression value is returned in Expr_Value. -- Returns TRUE if we hit an error. ------------------------------------------------------------------------------ First_Value : Symbol_Value := Expr_Value; function Both_Bool (Op : String) return Boolean is begin if First_Value.Kind /= Sk_Boolean then Error1 ("1st argument to " & Op & " was not a boolean value?"); return True; end if; if Expr_Value.Kind /= Sk_Boolean then Error1 ("2nd argument to " & Op & " was not a boolean value?"); return True; end if; return False; end Both_Bool; function Same (Op : String) return Boolean is begin if First_Value.Kind /= Expr_Value.Kind then Error1 ("Arguments to " & Op & " are not the same type?"); return True; end if; return False; end Same; begin ----Some binary operators are 2-part guys. Eat the 2nd part if it is there. Cur_Lexeme := Next_Token (In_File, Out_File, Want_Eol => False); if (Bin_Op = Lk_And and then Cur_Lexeme = Lk_Then) or else (Bin_Op = Lk_Or and then Cur_Lexeme = Lk_Else) then Cur_Lexeme := Next_Token (In_File, Out_File, Want_Eol => False); end if; ----The expression that follows starts with a primary. if Parse_Primary (In_File, Out_File) then return True; end if; ----If the lexeme that follows it is a binary operator then we have to -- check relative precedence. if Binary_Operator (Cur_Lexeme) and then Operator_Precedence (Bin_Op) < Operator_Precedence (Cur_Lexeme) then if Parse_Secondary (In_File, Out_File, Cur_Lexeme) then return True; end if; end if; ----Dispatch based upon the kind of operator we are dealing with. case Bin_Op is when Lk_And => if Both_Bool ("AND") then return True; end if; Expr_Value.Bool := First_Value.Bool and Expr_Value.Bool; return False; when Lk_Or => if Both_Bool ("OR") then return True; end if; Expr_Value.Bool := First_Value.Bool or Expr_Value.Bool; return False; when Lk_Xor => if Both_Bool ("XOR") then return True; end if; Expr_Value.Bool := First_Value.Bool xor Expr_Value.Bool; return False; when Lk_Eql => if Same ("=") then return True; end if; Expr_Value := (Permanent => False, Kind => Sk_Boolean, Bool => First_Value = Expr_Value); return False; when Lk_Neq => if Same ("=") then return True; end if; Expr_Value := (Permanent => False, Kind => Sk_Boolean, Bool => First_Value /= Expr_Value); return False; ----Anything else is a problem. when others => Error2 ("Internal error: unknown binary operator?", "Lexeme kind: " & Chop3 (Lexeme_Kind'Image (Bin_Op)) & " {" & String (Substring_To (Cur_Text, 1, 512)) & "}"); return True; end case; end Parse_Secondary; --\f function Parse_Expression (In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type) return Boolean is ------------------------------------------------------------------------------ -- Called to parse an expression. The expression is terminated by any -- non-expression-component that we find. eg. The THEN of an IF <expr> THEN -- The expression value is returned in Expr_Value. -- Returns TRUE if we hit an error. ------------------------------------------------------------------------------ begin if Parse_Primary (In_File, Out_File) then return True; end if; loop if not Binary_Operator (Cur_Lexeme) then return False; end if; if Parse_Secondary (In_File, Out_File, Cur_Lexeme) then return True; end if; end loop; end Parse_Expression; --\f procedure Handle_Control_If (In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type; Cur_Hide_State : Boolean) is ------------------------------------------------------------------------------ -- Called when Cur_Lexeme is Lk_If. We parse and handle the "if" control -- construct. ------------------------------------------------------------------------------ Controls : S_Natural; Control_Indent : S_Natural := Cur_Indent; Our_Outer : Boolean := Cur_Hide_State; Our_Cur : Boolean; Tmp : S_Long; begin ----We have an IF or an ELSIF; parse the conditional expression and check for -- a boolean value result. <<Condition_Loop>> null; Cur_Lexeme := Next_Token (In_File, Out_File, Want_Eol => False); if Parse_Expression (In_File, Out_File) then return; end if; if Expr_Value.Kind /= Sk_Boolean then Error2 ("IF control expression was not boolean?", "Expression kind : " & Chop3 (Symbol_Kind'Image (Expr_Value.Kind))); Our_Outer := True and not Normalizing; Our_Cur := True and not Normalizing; else Our_Cur := (Our_Outer or not Expr_Value.Bool) and not Normalizing; end if; ----The expression must be followed by a THEN which must in turn be the last -- (non-comment) item on the line. if Cur_Lexeme /= Lk_Then then Error1 ("IF <EXPR> was not followed by a THEN?"); return; end if; if Next_Token (In_File, Out_File, Want_Eol => True) /= Lk_Eol then Error2 ("IF <EXPR> THEN was followed by something other than " & "a comment?", "Lexeme kind: " & Chop3 (Lexeme_Kind'Image (Cur_Lexeme)) & " {" & String (Substring_To (Cur_Text, 1, 512)) & "}"); return; end if; ----Loop until we hit END IF or until we hit EOF. <<Reading_Loop>> null; ----Loop reading lines. If a line is not a control line ("--/") then it -- should be controlled (made into a "--//" line) if not already -- controlled if Our_Cur = True (which means that we are in the False arm -- of the IF and should be uncontrolled ("any "--//" removed) if Our_Cur = -- False. If we find a control line then exit the loop and go see what -- that line expects us to do. while not Next_Line (In_File) loop Controls := Cur_Line_Controls; if Controls = 1 then Output_Line (Out_File, Orig_Line); exit; end if; ----This line has a control ("--//") on it. Remove it if appropriate. if Controls = 2 then if Our_Cur then Output_Line (Out_File, Orig_Line); else Tmp := 1 + (Orig_Line.Length - Cur_Line.Length); if Tmp > 5 then Text_Io.Set_Col (Out_File, Text_Io.Positive_Count (1 + (Orig_Line.Length - Cur_Line.Length) - 5)); end if; Output_Line (Out_File, Cur_Line); end if; ----This line has no controls. Insert them if appropriate. else if Our_Cur then Text_Io.Put (Out_File, "--// "); end if; Output_Line (Out_File, Orig_Line); end if; ----Loop for the next line. end loop; ----We found a line with a control contstruct. Check it. case Next_Token (In_File, Out_File, Want_Eol => True) is ----Lk_Error is probably End-of-File. when Lk_Error => return; ----Lk_Eol is just a blank line. Ignore it. when Lk_Eol => goto Reading_Loop; ----Lk_Elsif is like an embedded if except that we don't recurse to handle it. -- If we just finished a THEN arm that was uncontrolled then all following -- arms, including us, will be controlled. when Lk_Elsif => if not Our_Cur then -- just finished uncontrolled THEN Our_Outer := True and -- so all future arms are controlled not Normalizing; end if; goto Condition_Loop; ----Lk_Else is the other arm of the IF. when Lk_Else => if Next_Token (In_File, Out_File, Want_Eol => True) /= Lk_Eol then Error2 ("While processing an IF; ELSE was followed by", "Lexeme kind: " & Chop3 (Lexeme_Kind'Image (Cur_Lexeme)) & " {" & String (Substring_To (Cur_Text, 1, 512)) & "}"); end if; ----If the THEN arm was controlled then the ELSE arm is uncontrolled and -- also the reverse. However, if some previous IF/ELSIF arm was uncontrolled -- or if some outer context forces us to be controlled then that overrides -- our wishes. if Our_Outer then -- previous ELSIF or outer context Our_Cur := True and not Normalizing; else -- ELSE is opposite of the THEN Our_Cur := not Our_Cur and not Normalizing; end if; goto Reading_Loop; ----Lk_End is presumably the End If; when Lk_End => if Next_Token (In_File, Out_File, Want_Eol => False) /= Lk_If then Error2 ("While processing an IF; END was not followed by IF.", "Lexeme kind: " & Chop3 (Lexeme_Kind'Image (Cur_Lexeme)) & " {" & String (Substring_To (Cur_Text, 1, 512)) & "}"); elsif Next_Token (In_File, Out_File, Want_Eol => False) /= Lk_Semicolon then Error2 ("While processing an IF; END IF was not followed by ;.", "Lexeme kind: " & Chop3 (Lexeme_Kind'Image (Cur_Lexeme)) & " {" & String (Substring_To (Cur_Text, 1, 512)) & "}"); end if; return; ----Anything else we recurse to handle or complain about. when others => Handle_Control (In_File, Out_File, Our_Cur); goto Reading_Loop; end case; end Handle_Control_If; --\f procedure Handle_Control (In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type; Cur_Hide_State : Boolean) is ------------------------------------------------------------------------------ -- Called when Cur_Lexeme is valid and we have just lexed the first token -- on a control line. We figure out what to do with it and then do it. ------------------------------------------------------------------------------ begin case Cur_Lexeme is when Lk_If => Handle_Control_If (In_File, Out_File, Cur_Hide_State); return; ----Anything else is an error. when others => Error2 ("Unexpected control token found.", "Lexeme kind: " & Chop3 (Lexeme_Kind'Image (Cur_Lexeme)) & " {" & String (Substring_To (Cur_Text, 1, 512)) & "}"); return; end case; end Handle_Control; --\f procedure Look_For_Control (In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type) is ------------------------------------------------------------------------------ -- Called when we are in a state where we just want to scan the input text -- as fast as we can looking for "--/" lines. ------------------------------------------------------------------------------ begin while not Next_Line (In_File) loop Output_Line (Out_File, Orig_Line); case Cur_Line_Controls is when 0 => null; when 1 => if Next_Token (In_File, Out_File, Want_Eol => True) /= Lk_Error and then Cur_Lexeme /= Lk_Eol then Handle_Control (In_File, Out_File, Cur_Hide_State => False); end if; when others => Error ("Unexpected --// found outside of controlled context."); end case; end loop; end Look_For_Control; --\f procedure Process_File (Input : Text_Io.File_Type; Output : Text_Io.File_Type; Normalize : Boolean := False) is ------------------------------------------------------------------------------ -- Input - Specifies the file to read -- Output - Specifies the file to write -- Normalize - Specifies True to override all parameters and to remove, -- unconditionally, all --//'s from the input file. -- -- Called after Parameter_Definition. -- -- Reads the input file and produces the output file. ------------------------------------------------------------------------------ begin ----Process the file. Normalizing := Normalize; Look_For_Control (Input, Output); ----Check for errors. if There_Were_Errors then raise Ada_Parameterization_Errors; end if; end Process_File; --\f procedure Process_File (Input : String; Output : String; Normalize : Boolean := False) is ------------------------------------------------------------------------------ -- Input - Specifies the file to read -- Output - Specifies the file to write -- Normalize - Specifies True to override all parameters and to remove, -- unconditionally, all --//'s from the input file. -- -- Called after Parameter_Definition. -- -- Reads the input file and produces the output file. ------------------------------------------------------------------------------ In_File : Text_Io.File_Type; Out_File : Text_Io.File_Type; Value : Symbol_Value; Success : Boolean; begin ----See if we are on/for an R1000. Symbol_Table.Symbol_Map.Find (Symbol_Table.Sym_Map, "R1000", Value, Success); if not Success then On_R1000 := False; else On_R1000 := Value.Bool; end if; ----Try to open the input file. begin Text_Io.Open (In_File, Text_Io.In_File, Input); exception when Text_Io.Name_Error => Error ("Input file " & Input & " not found?"); raise; when others => Error ("Unexpected exception when opening input file " & Input); raise; end; ----Try to open the output file. begin Text_Io.Create (Out_File, Text_Io.Out_File, Output); exception when others => begin Text_Io.Open (Out_File, Text_Io.Out_File, Output); exception when others => Text_Io.Close (In_File); Error ("Unexpected exception when opening output file " & Output); raise; end; end; ----Process the file. Normalizing := Normalize; Look_For_Control (In_File, Out_File); ----Close our input and output files. if There_Were_Errors then raise Ada_Parameterization_Errors; end if; Text_Io.Close (In_File); Text_Io.Close (Out_File); exception when others => Text_Io.Close (In_File); Text_Io.Close (Out_File); raise; end Process_File; --\f begin ----Breakset to skip everything that isn't whitespace and leave the result -- in the string. Set_Breakset (Skip_Whitespace, ' ' & Ascii.Ht & Ascii.Cr & Ascii.Lf & Ascii.Ff & Ascii.Vt, "", "XR"); end Ada_Parameterization;