|
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 - metrics - downloadIndex: B T
Length: 9215 (0x23ff)
Types: TextFile
Names: »B«
└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
└─⟦5cb1d1d7f⟧ »DATA«
└─⟦3b1ee7bd8⟧
└─⟦this⟧
with Io;
procedure Calculator (Print_Parse_Tree : in Boolean := False) is
Empty : constant := 127;
type Node_Type is (Binop, Unop, Number);
type Node_Rec (Rec_Type : Node_Type);
type Node is access Node_Rec;
type Node_Rec (Rec_Type : Node_Type) is
record
Tag : Node_Type;
case Rec_Type is
when Binop =>
Operator : Character;
Left_Operand : Node;
Right_Operand : Node;
when Unop =>
Uoperator : Character;
Operand : Node;
when Number =>
Num : Long_Integer;
end case;
end record;
Saved_Char : Character := Character'Val (Empty);
Register : Float;
function Get_Char return Character is
C : Character;
begin
if (Saved_Char /= Character'Val (Empty)) then
C := Saved_Char;
Saved_Char := Character'Val (Empty);
return (C);
elsif (Io.End_Of_File) then
return (Ascii.Nul);
elsif (Io.End_Of_Line) then
Io.Skip_Line;
return (Ascii.Cr);
else
Io.Get (C);
return (C);
end if;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'GET_CHAR'!");
raise;
end Get_Char;
procedure Unget_Char (C : in Character) is
begin
if (Saved_Char = Character'Val (Empty)) then
Saved_Char := C;
else
Io.Put_Line
("'UNGET_CHAR' CANNOT UNGET MORE THAN ONE CHARACTER AT A TIME!");
end if;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'UNGET_CHAR'!");
end Unget_Char;
function Next_Char return Character is
C : Character := ' ';
begin
while (C = ' ') loop
C := Get_Char;
end loop;
return (C);
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'NEXT_CHAR'!");
raise;
end Next_Char;
procedure Get_Num (C : in out Character; Result : out Long_Integer) is
N : Long_Integer := 0;
begin
loop
N := (10 * N) + (Character'Pos (C) - Character'Pos ('0'));
C := Get_Char;
exit when C not in '0' .. '9';
end loop;
Unget_Char (C);
Result := N;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'GET_NUM'!");
raise;
end Get_Num;
function Binop_Node
(Opor : in Character; Lopand : in Node; Ropand : in Node)
return Node is
N : Node;
begin
if ((Lopand = null) or else (Ropand = null)) then
return (null);
else
N := new Node_Rec (Binop);
N.Tag := Binop;
N.Operator := Opor;
N.Left_Operand := Lopand;
N.Right_Operand := Ropand;
return (N);
end if;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'BINOP_NODE'!");
raise;
end Binop_Node;
function Unop_Node (Opor : in Character; Opand : in Node) return Node is
N : Node;
begin
if (Opand = null) then
return null;
else
N := new Node_Rec (Unop);
N.Tag := Unop;
N.Uoperator := Opor;
N.Operand := Opand;
return N;
end if;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'UNOP_NODE'!");
raise;
end Unop_Node;
function Number_Node (I : in Long_Integer) return Node is
N : Node;
begin
N := new Node_Rec (Number);
N.Tag := Number;
N.Num := I;
return (N);
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'NUMBER_NODE'!");
raise;
end Number_Node;
procedure Print_Tree (N : in Node) is
--
procedure Ptree (N : in Node; Depth : in Natural) is
begin
case N.Tag is
when Binop =>
Ptree (N.Left_Operand, Depth + 2);
Io.Put (Depth);
Io.Put (' ');
Io.Put (N.Operator);
Io.New_Line;
Ptree (N.Right_Operand, Depth + 2);
when Unop =>
Io.Put (Depth);
Io.Put (' ');
Io.Put (N.Uoperator);
Io.New_Line;
Ptree (N.Operand, Depth + 2);
when Number =>
Io.Put (Depth);
Io.Put (' ');
Io.Put (Float (N.Num), 0, 0, 0);
Io.New_Line;
end case;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'PTREE'!");
raise;
end Ptree;
--
begin
Ptree (N, 0);
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'PRINT_TREE'!");
raise;
end Print_Tree;
function Term return Node;
function Expr return Node is
C : Character;
N : Node;
begin
N := Term;
if (N /= null) then
C := Next_Char;
if ((C = '+') or else (C = '-')) then
return (Binop_Node (C, N, Expr));
elsif (C /= Ascii.Cr) then
Unget_Char (C);
end if;
return (N);
end if;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'EXPR'!");
raise;
end Expr;
function Factor return Node;
function Term return Node is
C : Character;
N : Node;
begin
N := Factor;
if (N /= null) then
C := Next_Char;
if ((C = '*') or else (C = '/')) then
return (Binop_Node (C, N, Term));
else
Unget_Char (C);
end if;
end if;
return (N);
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'TERM'!");
raise;
end Term;
function Factor return Node is
C : Character;
Temp : Node;
Val : Long_Integer;
begin
C := Next_Char;
if ((C = 'R') or else (C = 'r')) then
return Number_Node (Long_Integer (Register));
elsif (C in '0' .. '9') then
Get_Num (C, Val);
return (Number_Node (Val));
elsif (C = '-') then
return (Unop_Node (C, Factor));
elsif (C = '(') then
Temp := Expr;
if Next_Char /= ')' then
Io.Put_Line ("CLOSING PARENTHESIS EXPECTED!");
end if;
return (Temp);
else
Io.Put_Line ("ILLEGAL EXPRESSION!");
return (null);
end if;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'FACTOR'!");
raise;
end Factor;
function Eval (N : in Node) return Float is
Op1 : Float;
Op2 : Float;
begin
case N.Tag is
when Binop =>
Op1 := Eval (N.Left_Operand);
Op2 := Eval (N.Right_Operand);
case N.Operator is
when '+' =>
return (Op1 + Op2);
when '-' =>
return (Op1 - Op2);
when '*' =>
return (Op1 * Op2);
when '/' =>
return (Op1 / Op2);
when others =>
Io.Put_Line ("ILLEGAL OPERATION ATTEMPTED!");
return (0.0);
end case;
when Unop =>
return (-Eval (N.Operand));
when Number =>
return (Float (N.Num));
end case;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'EVAL'!");
raise;
end Eval;
procedure Run is
N : Node;
C : Character;
begin
loop
Io.Put_Line ("ENTER AN ARITHMETIC EXPRESSION AND HIT <PROMOTE>.");
Io.Put_Line ("ENTER A NULL STRING TO EXIT.");
Io.Put ("> ");
N := Expr;
if (N /= null) then
if (Print_Parse_Tree) then
Io.New_Line;
Print_Tree (N);
end if;
Register := Eval (N);
Io.New_Line;
Io.Put (Register, 1, 0, 0);
Io.New_Line;
exit when False;
end if;
end loop;
exception
when Io.End_Error =>
Io.Put_Line ("PROGRAM TERMINATED.");
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN 'RUN'!");
raise;
end Run;
begin
Io.Put_Line ("TI-STYLE CALCULATOR:");
Run;
exception
when others =>
Io.Put_Line ("EXCEPTION CAUGHT IN MAIN PROCEDURE!");
raise;
end Calculator;