|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 20480 (0x5000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Variable_Table, seg_0463f4
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Tds, Error, Type_Table, Text_Io, Unbounded_String, Stack_Generic;
package body Variable_Table is
package Unlimited_String is new Unbounded_String (10);
Master_Table, Current_Table : Tds.Object;
Last_Inserted_Variable_Name : Unlimited_String.Variable_String;
type Context is
record
Table : Tds.Object;
Element : Natural;
end record;
Initialization_Context : Context;
package Type_Context_Stack is new Stack_Generic (Element => Context);
Context_Stack : Type_Context_Stack.Stack;
package Type_String_Stack is
new Stack_Generic (Element => Unlimited_String.Variable_String);
My_String_Stack : Type_String_Stack.Stack;
procedure Create (Variable_Name, Type_Name : in String;
L, C : in Natural) is
Source_Table, Target_Table : Tds.Object;
begin
Current_Table := Master_Table;
begin
Source_Table := Type_Table.Get_Type (Type_Name);
exception
when Type_Table.Demanded_Type_Does_Not_Exist =>
raise Type_Does_Not_Exist;
end;
Tds.Insert_Table_Symbol (Master_Table, Variable_Name, Type_Name, L, C);
Target_Table := Tds.Get_Table (Master_Table, Variable_Name);
Tds.Deep_Copy (Source_Table, Target_Table);
Last_Inserted_Variable_Name := Unlimited_String.Value (Variable_Name);
exception
when Tds.Name_Does_Not_Exist_In_This_Table |
Tds.Name_Does_Not_Correspond_To_A_Table |
Tds.Name_Does_Not_Correspond_To_A_Value |
Tds.Id_Does_Not_Exist_In_This_Table |
Tds.Id_Does_Not_Correspond_To_A_Table |
Tds.Id_Does_Not_Correspond_To_A_Value |
Type_Table.Demanded_Type_Does_Not_Exist =>
Error.Set_Type_Error (Error.None);
raise Error.Excep_Semantic_Error;
end Create;
procedure Create (Variable_Name : in String;
Variable_Type : in Dynamic_Value.Kinds;
L, C : in Natural) is
V : Dynamic_Value.Object;
begin
Current_Table := Master_Table;
case Variable_Type is
when Dynamic_Value.Unknown =>
null;
when Dynamic_Value.Integer_Number =>
Dynamic_Value.Set_Value (V, 0);
when Dynamic_Value.Boolean_Number =>
Dynamic_Value.Set_Value (V, False);
when Dynamic_Value.String_Of_Characters =>
Dynamic_Value.Set_Value (V, "");
when Dynamic_Value.Vocabulary_Word =>
Dynamic_Value.Set_Value (V, "", Dynamic_Value.Voca_Value);
when Dynamic_Value.Set_Of_Words =>
null;
end case;
Tds.Insert_Value_Symbol (Master_Table, Variable_Name, L, C, V);
Last_Inserted_Variable_Name := Unlimited_String.Value (Variable_Name);
end Create;
procedure Init_Acces_Path is
begin
Type_String_Stack.Make_Empty (My_String_Stack);
end Init_Acces_Path;
procedure Append_To_Acces_Path (Element : String) is
begin
Type_String_Stack.Push
(Unlimited_String.Value (Element), My_String_Stack);
end Append_To_Acces_Path;
function Get_Access_On (Name : in String) return Dynamic_Value.Object is
V : Dynamic_Value.Object;
begin
begin
V := Tds.Get_Access_On_Value (Current_Table, Name);
exception
when Tds.Name_Does_Not_Exist_In_This_Table =>
raise Variable_Does_Not_Exist;
when Tds.Name_Does_Not_Correspond_To_A_Value =>
raise Variable_Does_Not_Exist;
end;
return V;
exception
when Tds.Name_Does_Not_Exist_In_This_Table |
Tds.Name_Does_Not_Correspond_To_A_Table |
Tds.Name_Does_Not_Correspond_To_A_Value |
Tds.Id_Does_Not_Exist_In_This_Table |
Tds.Id_Does_Not_Correspond_To_A_Table |
Tds.Id_Does_Not_Correspond_To_A_Value =>
Error.Set_Type_Error (Error.None);
raise Error.Excep_Semantic_Error;
end Get_Access_On;
function Get_Access_Through_Path return Dynamic_Value.Object is
V : Dynamic_Value.Object;
My_Stack_Iterator : Type_String_Stack.Iterator;
Current_Element : Unlimited_String.Variable_String;
Temporary_Table : Tds.Object;
begin
Temporary_Table := Current_Table;
Current_Table := Master_Table;
Type_String_Stack.Init (My_Stack_Iterator, My_String_Stack);
Current_Element := Type_String_Stack.Value (My_Stack_Iterator);
Type_String_Stack.Next (My_Stack_Iterator);
while not (Type_String_Stack.Done (My_Stack_Iterator)) loop
Go_In (Unlimited_String.Image (Current_Element));
Current_Element := Type_String_Stack.Value (My_Stack_Iterator);
Type_String_Stack.Next (My_Stack_Iterator);
end loop;
V := Get_Access_On (Unlimited_String.Image (Current_Element));
Current_Table := Temporary_Table;
return V;
exception
when Tds.Name_Does_Not_Exist_In_This_Table |
Tds.Name_Does_Not_Correspond_To_A_Table |
Tds.Name_Does_Not_Correspond_To_A_Value |
Tds.Id_Does_Not_Exist_In_This_Table |
Tds.Id_Does_Not_Correspond_To_A_Table |
Tds.Id_Does_Not_Correspond_To_A_Value =>
Error.Set_Type_Error (Error.None);
raise Error.Excep_Semantic_Error;
end Get_Access_Through_Path;
procedure Go_In (Variable_Name : in String) is
T : Tds.Object;
begin
T := Tds.Get_Table (Current_Table, Variable_Name);
Current_Table := T;
exception
--when Tds.Name_Does_Not_Exist_In_This_Table =>
-- raise Variable_Does_Not_Exist;
--when Tds.Name_Does_Not_Correspond_To_A_Table =>
-- raise Cannot_Go_In_This_Variable;
when Tds.Name_Does_Not_Exist_In_This_Table |
Tds.Name_Does_Not_Correspond_To_A_Table |
Tds.Name_Does_Not_Correspond_To_A_Value |
Tds.Id_Does_Not_Exist_In_This_Table |
Tds.Id_Does_Not_Correspond_To_A_Table |
Tds.Id_Does_Not_Correspond_To_A_Value =>
Error.Set_Type_Error (Error.None);
raise Error.Excep_Semantic_Error;
end Go_In;
procedure Go_To_Top_Level is
begin
Current_Table := Master_Table;
end Go_To_Top_Level;
procedure Begin_Initialization is
use Tds;
begin
-- purger la pile
Type_Context_Stack.Make_Empty (Context_Stack);
if (Tds.Get_Kind_Of_Symbol
(Master_Table, Unlimited_String.Image
(Last_Inserted_Variable_Name)) =
Tds.Record_Value) then
Initialization_Context.Table :=
Tds.Get_Table (Master_Table, Unlimited_String.Image
(Last_Inserted_Variable_Name));
else
Initialization_Context.Table := Master_Table;
end if;
Initialization_Context.Element := 0;
end Begin_Initialization;
procedure Go_In_Inherited is
Name : Unlimited_String.Variable_String;
use Tds;
begin
if (Tds.Get_Number_Of_Symbols (Initialization_Context.Table) <
Initialization_Context.Element) then
-- nom de l'exception a revoir
--raise Initialization_Too_Long;
Error.Set_Type_Error (Error.None);
raise Error.Excep_Semantic_Error;
end if;
if (Initialization_Context.Element = 0) then
Initialization_Context.Element := 1;
end if;
Name := Unlimited_String.Value
(Tds.Get_Name (Initialization_Context.Table,
Initialization_Context.Element));
if (Tds.Get_Kind_Of_Symbol
(Initialization_Context.Table, Unlimited_String.Image (Name)) /=
Tds.Record_Value)
-- nom de l'exception a revoir
then
-- raise Cannot_Go_In_This_Variable;
Error.Set_Type_Error (Error.None);
raise Error.Excep_Semantic_Error;
end if;
Type_Context_Stack.Push (Initialization_Context, Context_Stack);
Initialization_Context.Table :=
Tds.Get_Table (Initialization_Context.Table,
Unlimited_String.Image (Name));
Initialization_Context.Element := 1;
exception
when Tds.Name_Does_Not_Exist_In_This_Table |
Tds.Name_Does_Not_Correspond_To_A_Table |
Tds.Name_Does_Not_Correspond_To_A_Value |
Tds.Id_Does_Not_Exist_In_This_Table |
Tds.Id_Does_Not_Correspond_To_A_Table |
Tds.Id_Does_Not_Correspond_To_A_Value =>
Error.Set_Type_Error (Error.None);
raise Error.Excep_Semantic_Error;
end Go_In_Inherited;
procedure Go_Out_Of_Inherited is
begin
Initialization_Context := Type_Context_Stack.Top (Context_Stack);
Type_Context_Stack.Pop (Context_Stack);
Initialization_Context.Element := Initialization_Context.Element + 1;
exception
when Type_Context_Stack.Underflow
-- raise Initialization_Too_Long;
-- exception
| Tds.Name_Does_Not_Exist_In_This_Table |
Tds.Name_Does_Not_Correspond_To_A_Table |
Tds.Name_Does_Not_Correspond_To_A_Value |
Tds.Id_Does_Not_Exist_In_This_Table |
Tds.Id_Does_Not_Correspond_To_A_Table |
Tds.Id_Does_Not_Correspond_To_A_Value =>
Error.Set_Type_Error (Error.None);
raise Error.Excep_Semantic_Error;
end Go_Out_Of_Inherited;
procedure Set_New_Value (Source : in Dynamic_Value.Object;
Target : in out Dynamic_Value.Object) is
use Dynamic_Value;
begin
if (Dynamic_Value.Get_Kind (Source) /=
Dynamic_Value.Get_Kind (Target)) then
case Dynamic_Value.Get_Kind (Source) is
when Dynamic_Value.Integer_Number =>
Error.Set_Type_Error (Error.Integer_Was_Expected);
when Dynamic_Value.Boolean_Number =>
Error.Set_Type_Error (Error.Boolean_Was_Expected);
when Dynamic_Value.String_Of_Characters =>
Error.Set_Type_Error (Error.String_Was_Expected);
when Dynamic_Value.Set_Of_Words =>
Error.Set_Type_Error (Error.Word_Was_Expected);
when Dynamic_Value.Unknown | Dynamic_Value.Vocabulary_Word =>
Error.Set_Type_Error (Error.None);
end case;
raise Error.Excep_Semantic_Error;
end if;
Dynamic_Value.Deep_Copy (Source, Target);
end Set_New_Value;
procedure Initialize_With (V : in Dynamic_Value.Object) is
Value : Dynamic_Value.Object;
Name : Unlimited_String.Variable_String;
use Tds;
begin
if (Tds.Get_Kind_Of_Symbol
(Master_Table, Unlimited_String.Image
(Last_Inserted_Variable_Name)) =
Record_Value) then
if (Initialization_Context.Element = 0) then
-- theoriquement toujours vrai
Initialization_Context.Element := 1;
Initialization_Context.Table :=
Tds.Get_Table (Master_Table,
Unlimited_String.Image
(Last_Inserted_Variable_Name));
end if;
Name := Unlimited_String.Value
(Tds.Get_Name (Initialization_Context.Table,
Initialization_Context.Element));
Value := Tds.Get_Access_On_Value (Initialization_Context.Table,
Unlimited_String.Image (Name));
Set_New_Value (V, Value);
Initialization_Context.Element :=
Initialization_Context.Element + 1;
else
Name := Unlimited_String.Value (Unlimited_String.Image
(Last_Inserted_Variable_Name));
Value := Tds.Get_Access_On_Value (Initialization_Context.Table,
Unlimited_String.Image (Name));
Set_New_Value (V, Value);
Initialization_Context.Element :=
Initialization_Context.Element + 1;
end if;
exception
when Tds.Name_Does_Not_Exist_In_This_Table |
Tds.Name_Does_Not_Correspond_To_A_Table |
Tds.Name_Does_Not_Correspond_To_A_Value |
Tds.Id_Does_Not_Exist_In_This_Table |
Tds.Id_Does_Not_Correspond_To_A_Table |
Tds.Id_Does_Not_Correspond_To_A_Value =>
Error.Set_Type_Error (Error.None);
raise Error.Excep_Semantic_Error;
end Initialize_With;
procedure Initialize_With (Variable_Name : in String) is
Name : Unlimited_String.Variable_String;
Source_Table, Target_Table : Tds.Object;
begin
if (Initialization_Context.Element /= 0) then
Name := Unlimited_String.Value
(Tds.Get_Name (Initialization_Context.Table,
Initialization_Context.Element));
else
Name := Unlimited_String.Value (Unlimited_String.Image
(Last_Inserted_Variable_Name));
end if;
Target_Table := Tds.Get_Table (Initialization_Context.Table,
Unlimited_String.Image (Name));
Source_Table := Tds.Get_Table (Master_Table, Variable_Name);
Tds.Deep_Copy (Source_Table, Target_Table);
Initialization_Context.Element := Initialization_Context.Element + 1;
end Initialize_With;
procedure Print is
begin
Text_Io.Put (" VARIABLES ");
Tds.Print (Master_Table);
end Print;
end Variable_Table;
nblk1=13
nid=6
hdr6=20
[0x00] rec0=24 rec1=00 rec2=01 rec3=00e
[0x01] rec0=17 rec1=00 rec2=02 rec3=002
[0x02] rec0=15 rec1=00 rec2=03 rec3=054
[0x03] rec0=1f rec1=00 rec2=0a rec3=062
[0x04] rec0=19 rec1=00 rec2=13 rec3=016
[0x05] rec0=18 rec1=00 rec2=0c rec3=02e
[0x06] rec0=1e rec1=00 rec2=05 rec3=012
[0x07] rec0=14 rec1=00 rec2=07 rec3=036
[0x08] rec0=1c rec1=00 rec2=10 rec3=026
[0x09] rec0=19 rec1=00 rec2=0b rec3=014
[0x0a] rec0=18 rec1=00 rec2=0e rec3=068
[0x0b] rec0=19 rec1=00 rec2=09 rec3=01e
[0x0c] rec0=07 rec1=00 rec2=12 rec3=02a
[0x0d] rec0=11 rec1=00 rec2=0f rec3=02a
[0x0e] rec0=19 rec1=00 rec2=11 rec3=00c
[0x0f] rec0=15 rec1=00 rec2=0d rec3=000
[0x10] rec0=15 rec1=00 rec2=0d rec3=000
[0x11] rec0=00 rec1=00 rec2=00 rec3=000
[0x12] rec0=00 rec1=00 rec2=00 rec3=000
tail 0x21542e98a86505191f5a6 0x42a00088462060003
Free Block Chain:
0x6: 0000 00 04 02 e7 80 33 20 20 20 20 20 20 20 20 20 20 ┆ 3 ┆
0x4: 0000 00 08 00 1e 00 0f 20 20 20 20 20 20 20 20 2d 2d ┆ --┆
0x8: 0000 00 00 00 06 80 03 65 61 6e 03 04 05 06 07 08 09 ┆ ean ┆