|
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: 26676 (0x6834)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
with Nodes;
with Lexical;
with Bounded_Strings;
with Gen_Stack;
with Error;
with Text_Io;
package body Symbol is
type Object (Length : Positive);
type Pobject is access Object;
type Symbols (A_Kind : Kind := None) is
record
Name : Lexical.Lexeme;
case A_Kind is
when Category =>
Actors : Pobject := null;
when Station =>
Sta_Type : Lexical.Lexeme; -- Un nom de categorie
Sta_Adress : Natural;
Sta_Category : Pobject :=
null; -- Ptr sur table des acteurs
when Actor =>
Act_Type : Types := T_Void;
Act_Number : Natural range 0 .. Actor_Table_Size - 1 := 0;
when Variable =>
Var_Type : Types := T_Void;
Var_Value : Integer := 0;
when Effect | Scene =>
Local_Table : Pobject := null;
Code : Nodes.Pnode := null;
when Begining =>
Beg_Code : Nodes.Pnode := null;
when Argument =>
Arg_Number : Positive := 1;
Arg_Value : Natural := 0; -- Un index dans la globale
when None =>
null;
end case;
end record;
type Psymbols is access Symbols; -- MUTABLE !!!
type Symbols_Array is array (Positive range <>) of Psymbols;
type Object (Length : Positive) is
record
The_Previous : Pobject;
The_Index : Natural;
The_Content : Symbols_Array (1 .. Length);
end record;
-- Pile des tables => profondeur d'appel de 20
package Table_Stack is new Gen_Stack (20, Pobject);
-- Variables du package symbol
Null_Lexeme : Lexical.Lexeme;
Number : Natural := 0;
Current_Table : Pobject := null; -- Table Courante (Active)
Global_Table : Pobject := null; -- Table Globale
Symbol_Table_Stack : Table_Stack.Object; -- Pile des tables
-- Fonctions de gestion locales
function Is_In_Table (The_Name : in Lexical.Lexeme; The_Table : in Pobject)
return Boolean is
begin
for I in 1 .. The_Table.The_Index loop
if Bounded_Strings.Is_Equal
(The_Table.The_Content (I).Name, The_Name) then
return True;
end if;
end loop;
return False;
end Is_In_Table;
function Is_Existing (The_Name : in Lexical.Lexeme) return Boolean is
Table_Pointer : Pobject;
begin
Table_Pointer := Current_Table;
while Table_Pointer /= null loop
if Is_In_Table (The_Name, Table_Pointer) then
return True;
end if;
Table_Pointer := Table_Pointer.The_Previous;
end loop;
return False;
end Is_Existing;
function Get_Index (From_Name : in Lexical.Lexeme; In_Table : in Pobject)
return Positive is
begin
for I in 1 .. In_Table.The_Index loop
if Bounded_Strings.Is_Equal
(In_Table.The_Content (I).Name, From_Name) then
return I;
end if;
end loop;
end Get_Index;
function Is_Arg_Number (The_Number : in Positive) return Boolean is
begin
for I in 1 .. Current_Table.The_Index loop
if (Current_Table.The_Content (I).A_Kind = Argument) then
if (Current_Table.The_Content (I).Arg_Number = The_Number) then
return True;
end if;
end if;
end loop;
return False;
end Is_Arg_Number;
-- Creation/Liberation
procedure New_Table (Length : in Positive) is
Table_Pointer : Pobject;
begin
Number := 0;
if (Current_Table = null) then
Current_Table := new Object (Length);
Current_Table.The_Previous := null;
Current_Table.The_Index := 0;
Global_Table :=
Current_Table; -- Init du pointeur sur la globale
else
Table_Pointer := new Object (Length);
Table_Pointer.The_Previous := Current_Table;
Table_Pointer.The_Index := 0;
case Current_Table.The_Content (Current_Table.The_Index).A_Kind is
when Category =>
-- On rattache la table des acteurs a la categorie correspondante
-- Suppose que la derniere entree dans la table a ete cette categorie
Current_Table.The_Content (Current_Table.The_Index).
Actors := Table_Pointer;
when Effect | Scene =>
-- On rattache la table locale a l'effet ou la scene correspondante
-- Suppose que la derniere entree dans la table a ete cet effet ou
-- cette scene !
Current_Table.The_Content (Current_Table.The_Index).
Local_Table := Table_Pointer;
when Station | Actor | Variable | Begining | Argument | None =>
null;
end case;
Current_Table := Table_Pointer;
end if;
end New_Table;
procedure Release_Table is
begin
if Current_Table /= Global_Table then
Current_Table := Global_Table;
end if;
end Release_Table;
procedure Init_Tables_Stack is
begin
Table_Stack.Push (Symbol_Table_Stack, Global_Table);
end Init_Tables_Stack;
procedure Set_Current_Table (Name : in Lexical.Lexeme) is
use Table_Stack;
Crt_Index : Positive;
begin
if not Is_In_Table (Name, Global_Table) then
Error.Handle (Bounded_Strings.Image (Name) &
" absent de la table !", Error.Internal);
else
if Is_Full (Symbol_Table_Stack) then
Error.Handle ("pile des tables pleine !", Error.Internal);
else
Crt_Index := Get_Index (Name, Global_Table);
Current_Table :=
Global_Table.The_Content (Crt_Index).Local_Table;
Push (Symbol_Table_Stack, Current_Table);
end if;
end if;
end Set_Current_Table;
procedure Reset_Current_Table is
use Table_Stack;
begin
if Is_Empty (Symbol_Table_Stack) then
Error.Handle ("pile des tables vide !", Error.Internal);
Current_Table := Global_Table;
Init_Tables_Stack;
else
Pop (Symbol_Table_Stack);
Current_Table := Get_Top (Symbol_Table_Stack);
end if;
end Reset_Current_Table;
-- Modification
procedure Add (The_Name : in Lexical.Lexeme; Of_Kind : in Kind) is
Table_Pointer : Pobject;
Crt_Index : Positive;
begin
if Current_Table.The_Index < Current_Table.Length then
if Is_Existing (The_Name) then
if Is_In_Table (The_Name, Global_Table) then
Table_Pointer := Global_Table;
else
Table_Pointer := Current_Table;
end if;
Crt_Index := Get_Index (The_Name, Table_Pointer);
if Table_Pointer.The_Content (Crt_Index).A_Kind /= Variable then
Error.Handle ("nom d'identificateur " &
Bounded_Strings.Image (The_Name) &
" deja utilise !", Error.External);
end if;
else
Current_Table.The_Index := Current_Table.The_Index + 1;
case Of_Kind is
when Category =>
Current_Table.The_Content (Current_Table.The_Index) :=
new Symbols'(A_Kind => Category,
Name => The_Name,
Actors => null);
when Station =>
Current_Table.The_Content (Current_Table.The_Index) :=
new Symbols'(A_Kind => Station,
Name => The_Name,
Sta_Type => Null_Lexeme,
Sta_Adress => 0,
Sta_Category => null);
when Actor =>
Current_Table.The_Content (Current_Table.The_Index) :=
new Symbols'(A_Kind => Actor,
Name => The_Name,
Act_Type => T_Error,
Act_Number => Number);
Number := Number + 1;
when Variable =>
Current_Table.The_Content (Current_Table.The_Index) :=
new Symbols'(A_Kind => Variable,
Name => The_Name,
Var_Type => T_Error,
Var_Value => 0);
when Effect =>
Current_Table.The_Content (Current_Table.The_Index) :=
new Symbols'(A_Kind => Effect,
Name => The_Name,
Local_Table => null,
Code => null);
when Scene =>
Current_Table.The_Content (Current_Table.The_Index) :=
new Symbols'(A_Kind => Scene,
Name => The_Name,
Local_Table => null,
Code => null);
when Begining =>
Current_Table.The_Content (Current_Table.The_Index) :=
new Symbols'(A_Kind => Begining,
Name => The_Name,
Beg_Code => null);
when Argument =>
Number := Number +
1; -- car Number init et raj a 0
Current_Table.The_Content (Current_Table.The_Index) :=
new Symbols'(A_Kind => Argument,
Name => The_Name,
Arg_Number => Number,
Arg_Value => 0);
when None =>
null;
end case;
end if;
else
Error.Handle ("table des symboles pleine !!", Error.Internal);
end if;
end Add;
procedure Set_Code (Name : in Lexical.Lexeme; The_Code : in Nodes.Pnode) is
Crt_Index : Positive;
begin
if not Is_In_Table (Name, Global_Table) then
Error.Handle ("symbole absent de la table globale !",
Error.Internal);
else
Crt_Index := Get_Index (Name, Global_Table);
case Global_Table.The_Content (Crt_Index).A_Kind is
when Effect | Scene =>
Global_Table.The_Content (Crt_Index).Code := The_Code;
when Begining =>
Global_Table.The_Content (Crt_Index).Beg_Code := The_Code;
when Category | Actor | Station | Variable | Argument | None =>
null;
end case;
end if;
end Set_Code;
procedure Set_Value (Name : in Lexical.Lexeme; The_Value : in Integer) is
Table_Pointer : Pobject;
Crt_Index : Positive;
begin
if not Is_Existing (Name) then
Error.Handle (Bounded_Strings.Image (Name) & " inexistant !",
Error.Internal);
else
if Is_In_Table (Name, Current_Table) then
Table_Pointer := Current_Table;
else
Table_Pointer := Global_Table;
end if;
Crt_Index := Get_Index (Name, Table_Pointer);
case Table_Pointer.The_Content (Crt_Index).A_Kind is
when Station =>
Table_Pointer.The_Content (Crt_Index).Sta_Adress :=
The_Value;
when Variable =>
Table_Pointer.The_Content (Crt_Index).Var_Value :=
The_Value;
when Category | Actor | Effect | Scene |
Argument | Begining | None =>
null;
end case;
end if;
end Set_Value;
procedure Set_Arg_Value (With_Value : in Lexical.Lexeme;
Arg_Number : in Positive) is
Crt_Index : Positive;
begin
if not Is_Arg_Number (Arg_Number) then
Error.Handle ("argument " & Integer'Image (Arg_Number) &
" inexistant !", Error.Internal);
else
if not Is_In_Table (With_Value, Global_Table) then
Error.Handle ("station " & Bounded_Strings.Image (With_Value) &
" inexistante !", Error.Internal);
else
Crt_Index := Get_Index (With_Value, Global_Table);
Current_Table.The_Content (Arg_Number).Arg_Value := Crt_Index;
end if;
end if;
end Set_Arg_Value;
procedure Set_Type (Name : in Lexical.Lexeme; The_Type : in Types) is
Crt_Index : Positive;
begin
if not Is_In_Table (Name, Current_Table) then
Error.Handle (Bounded_Strings.Image (Name) & " inexistant !",
Error.External);
else
Crt_Index := Get_Index (Name, Current_Table);
case Current_Table.The_Content (Crt_Index).A_Kind is
when Variable =>
Current_Table.The_Content (Crt_Index).Var_Type := The_Type;
when Actor =>
Current_Table.The_Content (Crt_Index).Act_Type := The_Type;
when Category | Station | Argument |
Effect | Scene | Begining | None =>
null;
end case;
end if;
end Set_Type;
procedure Set_Type (From_Station : in Lexical.Lexeme;
With_Category : in Lexical.Lexeme) is
Crt_Index : Positive;
begin
if not Is_In_Table (From_Station, Global_Table) then
Error.Handle ("station " & Bounded_Strings.Image (From_Station) &
" inexistante !", Error.Internal);
else
if not Is_In_Table (With_Category, Global_Table) then
Error.Handle ("categorie " &
Bounded_Strings.Image (With_Category) &
" inexistante !", Error.External);
else
Crt_Index := Get_Index (From_Station, Global_Table);
if (Global_Table.The_Content (Crt_Index).A_Kind = Station) then
Bounded_Strings.Affect
(Global_Table.The_Content (Crt_Index).Sta_Type,
With_Category);
Global_Table.The_Content (Crt_Index).Sta_Category :=
Global_Table.The_Content
(Get_Index (With_Category, Current_Table)).Actors;
else
null;
end if;
end if;
end if;
end Set_Type;
-- Consultation
function Get_Code (From_Name : in Lexical.Lexeme) return Nodes.Pnode is
Crt_Index : Positive;
begin
if not Is_In_Table (From_Name, Global_Table) then
Error.Handle
("code de " & Bounded_Strings.Image (From_Name) & " absent !",
Error.Internal);
return null;
else
Crt_Index := Get_Index (From_Name, Global_Table);
case Global_Table.The_Content (Crt_Index).A_Kind is
when Effect | Scene =>
return Global_Table.The_Content (Crt_Index).Code;
when Begining =>
return Global_Table.The_Content (Crt_Index).Beg_Code;
when Category | Actor | Station | Variable | Argument | None =>
return null;
end case;
end if;
end Get_Code;
function Get_Value (From_Name : in Lexical.Lexeme) return Integer is
Crt_Index : Positive;
Table_Pointer : Pobject;
begin
if not Is_Existing (From_Name) then
Error.Handle (Bounded_Strings.Image (From_Name) & " inexistant !",
Error.Internal);
return 0;
else
if Is_In_Table (From_Name, Current_Table) then
Table_Pointer := Current_Table;
else
Table_Pointer := Global_Table;
end if;
Crt_Index := Get_Index (From_Name, Table_Pointer);
case Table_Pointer.The_Content (Crt_Index).A_Kind is
when Station =>
return Table_Pointer.The_Content (Crt_Index).Sta_Adress;
when Variable =>
return Table_Pointer.The_Content (Crt_Index).Var_Value;
when Argument =>
Crt_Index :=
Table_Pointer.The_Content (Crt_Index).Arg_Value;
return Global_Table.The_Content (Crt_Index).Sta_Adress;
when Category | Actor | Effect | Scene | Begining | None =>
return 0;
end case;
end if;
end Get_Value;
function Get_Effectfiv_Arg_Name
(Formal_Param : in Lexical.Lexeme) return Lexical.Lexeme is
use Table_Stack;
My_Table : Pobject;
Crt_Index : Positive;
begin
if Is_In_Table (Formal_Param, Global_Table) then
return Formal_Param;
else
Pop (Symbol_Table_Stack);
My_Table := Get_Top (Symbol_Table_Stack);
end if;
if not Is_In_Table (Formal_Param, My_Table) then
Error.Handle ("argument " & Bounded_Strings.Image (Formal_Param) &
" inexistant !", Error.Internal);
Push (Symbol_Table_Stack, Current_Table);
return Null_Lexeme;
else
Crt_Index := Get_Index (Formal_Param, My_Table);
Crt_Index := My_Table.The_Content (Crt_Index).Arg_Value;
Push (Symbol_Table_Stack, Current_Table);
return Global_Table.The_Content (Crt_Index).Name;
end if;
end Get_Effectfiv_Arg_Name;
function Get_Sta_Actor
(In_Station : in Lexical.Lexeme; From_Actor : in Lexical.Lexeme)
return Integer is
Crt_Index : Positive;
Table_Pointer : Pobject;
begin
if not Is_In_Table (In_Station, Global_Table) then
Error.Handle ("station " & Bounded_Strings.Image (In_Station) &
" inexistante !", Error.Internal);
return 0;
else
Crt_Index := Get_Index (In_Station, Global_Table);
Table_Pointer := Global_Table.The_Content (Crt_Index).Sta_Category;
if not Is_In_Table (From_Actor, Table_Pointer) then
Error.Handle ("acteur " & Bounded_Strings.Image (From_Actor) &
" inexistant !", Error.Internal);
return 0;
else
Crt_Index := Get_Index (From_Actor, Table_Pointer);
return Table_Pointer.The_Content (Crt_Index).Act_Number;
end if;
end if;
end Get_Sta_Actor;
function Get_Arg_Actor
(In_Station : in Lexical.Lexeme; From_Actor : in Lexical.Lexeme)
return Integer is
Crt_Index : Positive;
Table_Pointer : Pobject;
begin
Crt_Index := Get_Index (In_Station, Current_Table);
Crt_Index := Current_Table.The_Content (Crt_Index).Arg_Value;
Table_Pointer := Global_Table.The_Content (Crt_Index).Sta_Category;
if not Is_In_Table (From_Actor, Table_Pointer) then
Error.Handle ("acteur " & Bounded_Strings.Image (From_Actor) &
" inexistant !", Error.Internal);
return 0;
else
Crt_Index := Get_Index (From_Actor, Table_Pointer);
return Table_Pointer.The_Content (Crt_Index).Act_Number;
end if;
end Get_Arg_Actor;
function Get_Actor_Number
(In_Station : in Lexical.Lexeme; From_Actor : in Lexical.Lexeme)
return Integer is
Crt_Index : Positive;
Table_Pointer : Pobject;
begin
if not Is_In_Table (In_Station, Current_Table) then
Table_Pointer := Global_Table;
else
Table_Pointer := Current_Table;
end if;
Crt_Index := Get_Index (In_Station, Table_Pointer);
if (Table_Pointer.The_Content (Crt_Index).A_Kind = Argument) then
return Get_Arg_Actor (In_Station, From_Actor);
else
return Get_Sta_Actor (In_Station, From_Actor);
end if;
end Get_Actor_Number;
function Get_Type (From_Name : in Lexical.Lexeme) return Types is
Crt_Index : Positive;
Table_Pointer : Pobject;
begin
if not Is_Existing (From_Name) then
Error.Handle (Bounded_Strings.Image (From_Name) & " inexistant !",
Error.Internal);
return T_Error;
else
if Is_In_Table (From_Name, Current_Table) then
Table_Pointer := Current_Table;
else
Table_Pointer := Global_Table;
end if;
Crt_Index := Get_Index (From_Name, Table_Pointer);
case Table_Pointer.The_Content (Crt_Index).A_Kind is
when Category =>
return T_Category;
when Station =>
return T_Station;
when Variable =>
return Current_Table.The_Content (Crt_Index).Var_Type;
when Effect =>
return T_Effect;
when Scene =>
return T_Scene;
when Begining =>
return T_Begining;
when Argument =>
return Get_Type (Global_Table.The_Content
(Table_Pointer.The_Content (Crt_Index).
Arg_Value).Name);
when Actor | None =>
return T_Error;
end case;
end if;
end Get_Type;
function Get_Type
(In_Station : in Lexical.Lexeme; From_Actor : in Lexical.Lexeme)
return Types is
Crt_Index : Positive;
Table_Pointer : Pobject;
begin
if not Is_In_Table (In_Station, Global_Table) then
Error.Handle ("station " & Bounded_Strings.Image (From_Actor) &
" inexistante !", Error.External);
return T_Error;
else
Crt_Index := Get_Index (In_Station, Global_Table);
Table_Pointer := Global_Table.The_Content (Crt_Index).Actors;
if not Is_In_Table (From_Actor, Table_Pointer) then
Error.Handle ("acteur " & Bounded_Strings.Image (From_Actor) &
"inexistant pour cette station !",
Error.External);
return T_Error;
else
Crt_Index := Get_Index (From_Actor, Table_Pointer);
return Table_Pointer.The_Content (Crt_Index).Act_Type;
end if;
end if;
end Get_Type;
-- Tests
procedure Print_Recur (P : in Pobject) is
use Text_Io;
Done : Boolean := False;
I : Natural;
Index : Natural;
begin
I := 1;
Put_Line ("Debut-------------");
while ((P /= null) and then (not Done)) loop
Put (Integer'Image (I) & " ");
Put (Bounded_Strings.Image (P.The_Content (I).Name) & " ");
case P.The_Content (I).A_Kind is
when Category =>
Put_Line ("CAT");
Print_Recur (P.The_Content (I).Actors);
when Station =>
Put (Bounded_Strings.Image (P.The_Content (I).Sta_Type));
Put_Line (Integer'Image (P.The_Content (I).Sta_Adress));
-- Print_Recur (P.The_Content(I).Sta_Category);
when Actor =>
Put ("ACT ");
Put_Line (Integer'Image (P.The_Content (I).Act_Number));
when Variable =>
Put ("VAR = ");
Put_Line (Integer'Image (Get_Value
(P.The_Content (I).Name)));
when Effect =>
Put_Line ("EFF");
Current_Table := P.The_Content (I).Local_Table;
Print_Recur (Current_Table);
Release_Table;
when Scene =>
Put_Line ("SCE");
Current_Table := P.The_Content (I).Local_Table;
Print_Recur (Current_Table);
Release_Table;
when Argument =>
Put ("ARG");
Put (Integer'Image (P.The_Content (I).Arg_Number) & " : ");
Index := P.The_Content (I).Arg_Value;
if Index /= 0 then
Put (Bounded_Strings.Image
(Global_Table.The_Content (Index).Name));
Put_Line (Integer'Image (Get_Value
(P.The_Content (I).Name)));
else
Put_Line ("0");
end if;
when Begining =>
Put_Line ("BEG");
when None =>
null;
end case;
if I >= P.The_Index then
Done := True;
else
I := I + 1;
end if;
end loop;
Put_Line ("Fin--------------");
end Print_Recur;
procedure Print is
begin
Print_Recur (Current_Table);
end Print;
end Symbol;