|
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: 31744 (0x7c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Compiler_Action, seg_046901
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Text_Io, Error, Dynamic_Value, Unbounded_String;
package body Compiler_Action is
package Unlimited_String is new Unbounded_String (10);
package Argument_List is new Queue_Generic (Dynamic_Value.Object);
type Acces_Argument_List is access Argument_List.Queue;
type Action_Node (What : Action_Kinds := Unknown_Action) is
record
case What is
when Unknown_Action =>
null;
when Write_Action =>
List_Of_Argument : Acces_Argument_List;
when Conditional_Action =>
The_Condition : Dynamic_Node.Object;
The_True_Bloc : Acces_List;
The_False_Bloc : Acces_List;
Evaluation_Flag : Boolean;
when Affect_Action =>
The_Source : Dynamic_Node.Object;
The_Target : Dynamic_Node.Object;
when Append_In_Set_Of_Word =>
The_Word : Dynamic_Node.Object;
The_Target_Set : Dynamic_Node.Object;
when Remove_From_Set_Of_Word =>
The_Out_Word : Dynamic_Node.Object;
The_Reduced_Set : Dynamic_Node.Object;
when Clear_Set_Of_Word =>
The_Set : Dynamic_Node.Object;
when Quit_Action =>
null;
end case;
end record;
procedure Create_Action (The_Action : in out Object; What : Action_Kinds) is
D_N1, D_N2 : Dynamic_Node.Object;
A_L_T, A_L_F : Acces_List;
A_Arg_List : Acces_Argument_List;
D_N : Dynamic_Node.Object;
An_Action : Object;
begin
case What is
when Write_Action =>
A_Arg_List := new Argument_List.Queue;
Argument_List.Make_Empty (A_Arg_List.all);
The_Action := new Action_Node'(What => Write_Action,
List_Of_Argument => A_Arg_List);
when Conditional_Action =>
A_L_T := new Action_List.Queue;
Action_List.Make_Empty (A_L_T.all);
A_L_F := new Action_List.Queue;
Action_List.Make_Empty (A_L_F.all);
The_Action := new Action_Node'(What => Conditional_Action,
The_Condition => D_N,
The_True_Bloc => A_L_T,
The_False_Bloc => A_L_F,
Evaluation_Flag => True);
when Affect_Action =>
The_Action := new Action_Node'(What => Affect_Action,
The_Source => D_N,
The_Target => D_N);
when Append_In_Set_Of_Word =>
Dynamic_Node.Create_Value (D_N1);
Dynamic_Node.Create_Value (D_N2);
The_Action := new Action_Node'(What => Append_In_Set_Of_Word,
The_Word => D_N1,
The_Target_Set => D_N2);
when Remove_From_Set_Of_Word =>
Dynamic_Node.Create_Value (D_N1);
Dynamic_Node.Create_Value (D_N2);
The_Action := new Action_Node'(What => Remove_From_Set_Of_Word,
The_Out_Word => D_N1,
The_Reduced_Set => D_N2);
when Clear_Set_Of_Word =>
Dynamic_Node.Create_Value (D_N);
The_Action := new Action_Node'(What => Clear_Set_Of_Word,
The_Set => D_N);
when Quit_Action =>
The_Action := new Action_Node'(What => Quit_Action);
when Unknown_Action =>
null;
end case;
end Create_Action;
procedure Create_List (The_Action_List : in out Acces_List) is
begin
The_Action_List := new Action_List.Queue;
Action_List.Make_Empty (The_Action_List.all);
end Create_List;
procedure Set_Write_Argument (The_Action : in out Object;
Argument_Type : Argument_Kinds;
The_Argument : Dynamic_Node.Object) is
use Dynamic_Node;
Tmp_Arg : Dynamic_Value.Object;
begin
if (Argument_Type /= Write_Argument) then
raise Bad_Argument_Type;
end if;
if ((Dynamic_Node.Get_Type_Of_Object (The_Argument) =
Dynamic_Node.Type_Unknown) or
(Dynamic_Node.Get_Type_Of_Object (The_Argument) =
Dynamic_Node.Type_Bool)) then
Error.Set_Type_Error (Error.Unauthorized_Type_For_Write);
raise Error.Excep_Semantic_Error;
end if;
Tmp_Arg := Dynamic_Node.Get_Value (The_Argument);
Argument_List.Add (The_Action.List_Of_Argument.all, Tmp_Arg);
end Set_Write_Argument;
procedure Set_Affect_Argument (The_Action : in out Object;
Argument_Type : Argument_Kinds;
The_Argument : Dynamic_Node.Object) is
use Dynamic_Node;
begin
if ((Argument_Type /= Source_Argument) and
(Argument_Type /= Target_Argument)) then
raise Bad_Argument_Type;
end if;
if (Argument_Type = Source_Argument) then
if (Dynamic_Node.Get_Kind (The_Action.The_Target) /=
Dynamic_Node.Unknown) then
if ((Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Get_Type_Of_Object
(The_Action.The_Target))) then
Error.Set_Type_Error
(Error.Unauthorized_Type_For_This_Affectation);
raise Error.Excep_Semantic_Error;
end if;
else
if ((Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_Int) and
(Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_String)) then
Error.Set_Type_Error
(Error.Unauthorized_Type_For_This_Affectation);
raise Error.Excep_Semantic_Error;
end if;
end if;
The_Action.The_Source := The_Argument;
else -- cas de la cible
if (Dynamic_Node.Get_Kind (The_Action.The_Source) /=
Dynamic_Node.Unknown) then
if ((Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Get_Type_Of_Object
(The_Action.The_Source))) then
Error.Set_Type_Error
(Error.Unauthorized_Type_For_This_Affectation);
raise Error.Excep_Semantic_Error;
end if;
else
if ((Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_Int) and
(Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_String)) then
Error.Set_Type_Error
(Error.Unauthorized_Type_For_This_Affectation);
raise Error.Excep_Semantic_Error;
end if;
end if;
The_Action.The_Target := The_Argument;
end if;
end Set_Affect_Argument;
procedure Set_Append_Argument (The_Action : in out Object;
Argument_Type : Argument_Kinds;
The_Argument : Dynamic_Node.Object) is
use Dynamic_Node;
begin
if ((Argument_Type /= Source_Argument) and
(Argument_Type /= Target_Argument)) then
raise Bad_Argument_Type;
end if;
if (Argument_Type = Source_Argument) then
if (Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_Voca) then
Error.Set_Type_Error (Error.Word_Was_Expected);
raise Error.Excep_Semantic_Error;
end if;
The_Action.The_Word := The_Argument;
else
if (Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_Set_Words) then
Error.Set_Type_Error (Error.Set_Was_Expected);
raise Error.Excep_Semantic_Error;
end if;
The_Action.The_Target_Set := The_Argument;
end if;
end Set_Append_Argument;
procedure Set_Remove_Argument (The_Action : in out Object;
Argument_Type : Argument_Kinds;
The_Argument : Dynamic_Node.Object) is
use Dynamic_Node;
begin
if ((Argument_Type /= Source_Argument) and
(Argument_Type /= Target_Argument)) then
raise Bad_Argument_Type;
end if;
if (Argument_Type = Source_Argument) then
if (Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_Voca) then
Error.Set_Type_Error (Error.Word_Was_Expected);
raise Error.Excep_Semantic_Error;
end if;
The_Action.The_Out_Word := The_Argument;
else
if (Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_Set_Words) then
Error.Set_Type_Error (Error.Set_Was_Expected);
raise Error.Excep_Semantic_Error;
end if;
The_Action.The_Reduced_Set := The_Argument;
end if;
end Set_Remove_Argument;
procedure Set_Clear_Argument (The_Action : in out Object;
Argument_Type : Argument_Kinds;
The_Argument : Dynamic_Node.Object) is
use Dynamic_Node;
begin
if (Argument_Type /= Target_Argument) then
raise Bad_Argument_Type;
end if;
if (Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_Set_Words) then
Error.Set_Type_Error (Error.Set_Was_Expected);
raise Error.Excep_Semantic_Error;
end if;
The_Action.The_Set := The_Argument;
end Set_Clear_Argument;
procedure Set_Condition (The_Action : in out Object;
Argument_Type : Argument_Kinds;
The_Argument : Dynamic_Node.Object) is
use Dynamic_Node;
begin
if (Argument_Type /= Condition_Argument) then
raise Bad_Argument_Type;
end if;
if (Dynamic_Node.Get_Type_Of_Object (The_Argument) /=
Dynamic_Node.Type_Bool) then
Error.Set_Type_Error (Error.Boolean_Was_Expected);
raise Error.Excep_Semantic_Error;
end if;
The_Action.The_Condition := The_Argument;
end Set_Condition;
procedure Set_Argument (The_Action : in out Object;
Argument_Type : Argument_Kinds;
The_Argument : Dynamic_Node.Object) is
begin
case The_Action.What is
when Write_Action =>
Set_Write_Argument (The_Action, Argument_Type, The_Argument);
when Affect_Action =>
Set_Affect_Argument (The_Action, Argument_Type, The_Argument);
when Append_In_Set_Of_Word =>
Set_Append_Argument (The_Action, Argument_Type, The_Argument);
when Remove_From_Set_Of_Word =>
Set_Remove_Argument (The_Action, Argument_Type, The_Argument);
when Clear_Set_Of_Word =>
Set_Clear_Argument (The_Action, Argument_Type, The_Argument);
when Conditional_Action =>
Set_Condition (The_Action, Argument_Type, The_Argument);
when Quit_Action | Unknown_Action =>
null;
end case;
end Set_Argument;
procedure Set_Argument (The_Action : in out Object;
Argument_Type : Argument_Kinds;
The_Argument : Object) is
begin
case Argument_Type is
when True_Component =>
Action_List.Add (The_Action.The_True_Bloc.all, The_Argument);
when False_Component =>
Action_List.Add (The_Action.The_False_Bloc.all, The_Argument);
when others =>
raise Bad_Argument_Type;
end case;
end Set_Argument;
function Get_True_Bloc (Of_Action : Object) return Acces_List is
begin
if Of_Action.What = Conditional_Action then
return Of_Action.The_True_Bloc;
else
raise Bad_Argument_Type;
end if;
end Get_True_Bloc;
function Get_False_Bloc (Of_Action : Object) return Acces_List is
begin
if Of_Action.What = Conditional_Action then
return Of_Action.The_False_Bloc;
else
raise Bad_Argument_Type;
end if;
end Get_False_Bloc;
function Get_Kind (Of_Action : Object) return Action_Kinds is
begin
return Of_Action.What;
end Get_Kind;
procedure Print_Action (The_Action : Object) is
begin
case The_Action.What is
when Write_Action =>
Text_Io.Put_Line ("ACTION ECRIRE");
when Conditional_Action =>
Text_Io.Put_Line ("ACTION CONDITIONNELLE, de condition");
Dynamic_Node.Print (The_Action.The_Condition);
when Affect_Action =>
Text_Io.Put_Line ("ACTION AFFECTATION");
Text_Io.New_Line;
Dynamic_Node.Print (The_Action.The_Source);
Text_Io.New_Line;
Dynamic_Node.Print (The_Action.The_Target);
when Append_In_Set_Of_Word =>
Text_Io.Put_Line ("ACTION AJOUT ENSEMBLE");
--Dynamic_Node.Print (The_Action.The_Word);
--Dynamic_Node.Print (The_Action.The_Target_Set);
when Remove_From_Set_Of_Word =>
Text_Io.Put_Line ("ACTION RETIRER ENSEMBLE");
--Dynamic_Node.Print (The_Action.The_Out_Word);
--Dynamic_Node.Print (The_Action.The_Reduced_Set);
when Clear_Set_Of_Word =>
Text_Io.Put_Line ("ACTION VIDER ENSEMBLE");
--Dynamic_Node.Print (The_Action.The_Set);
when Quit_Action =>
Text_Io.Put_Line ("ACTIION QUITTER");
when others =>
null;
end case;
end Print_Action;
procedure Print_List (The_List : Acces_List) is
It : Action_List.Iterator;
begin
Action_List.Init (It, The_List.all);
while not Action_List.Done (It) loop
Print_Action (Action_List.Value (It));
Action_List.Next (It);
end loop;
end Print_List;
procedure Evaluate_Action (The_Action : Object) is
begin
case The_Action.What is
when Conditional_Action =>
Dynamic_Node.Evaluate (The_Action.The_Condition);
The_Action.Evaluation_Flag :=
Dynamic_Value.Get_Value (Dynamic_Node.Get_Value
(The_Action.The_Condition));
if (The_Action.Evaluation_Flag) then
Evaluate (The_Action.The_True_Bloc);
else
Evaluate (The_Action.The_False_Bloc);
end if;
when others =>
null;
end case;
end Evaluate_Action;
procedure Execute_Action (The_Action : in Object) is
It : Action_List.Iterator;
It_Arg : Argument_List.Iterator;
Cond, Sv, Tv : Dynamic_Value.Object;
Arg_Kind : Dynamic_Value.Kinds;
I : Integer;
S : Unlimited_String.Variable_String;
use Dynamic_Value;
begin
case The_Action.What is
when Write_Action =>
Argument_List.Init (It_Arg, The_Action.List_Of_Argument.all);
while not Argument_List.Done (It_Arg) loop
Arg_Kind := Dynamic_Value.Get_Kind
(Argument_List.Value (It_Arg));
case Arg_Kind is
when Dynamic_Value.String_Of_Characters =>
Text_Io.Put (Dynamic_Value.Get_Value
(Argument_List.Value (It_Arg)));
when Dynamic_Value.Integer_Number =>
Text_Io.Put (Integer'Image (Dynamic_Value.Get_Value
(Argument_List.Value
(It_Arg))));
when Dynamic_Value.Set_Of_Words =>
Text_Io.New_Line;
Dynamic_Value.Print (Argument_List.Value (It_Arg));
when Dynamic_Value.Boolean_Number |
Dynamic_Value.Unknown |
Dynamic_Value.Vocabulary_Word =>
null;
end case;
Argument_List.Next (It_Arg);
end loop;
Text_Io.New_Line;
when Conditional_Action =>
if (The_Action.Evaluation_Flag = True) then
Execute (The_Action.The_True_Bloc);
else
Execute (The_Action.The_False_Bloc);
end if;
when Affect_Action =>
Dynamic_Node.Evaluate (The_Action.The_Source);
Dynamic_Node.Evaluate (The_Action.The_Target);
Sv := Dynamic_Node.Get_Value (The_Action.The_Source);
Tv := Dynamic_Node.Get_Value (The_Action.The_Target);
if (Dynamic_Value.Get_Kind (Sv) =
Dynamic_Value.Get_Kind (Tv)) then
case Dynamic_Value.Get_Kind (Sv) is
when Integer_Number =>
I := Dynamic_Value.Get_Value (Sv);
Dynamic_Value.Set_Value (Tv, I);
when String_Of_Characters =>
S := Unlimited_String.Value
(Dynamic_Value.Get_Value (Sv));
Dynamic_Value.Set_Value
(Tv, Unlimited_String.Image (S));
when others =>
null;
end case;
-- Dynamic_Node.Set_Value (The_Action.The_Target, Sv);
else
raise Bad_Argument_Type;
end if;
when Append_In_Set_Of_Word =>
Dynamic_Node.Evaluate (The_Action.The_Word);
Dynamic_Node.Evaluate (The_Action.The_Target_Set);
Sv := Dynamic_Node.Get_Value (The_Action.The_Word);
Tv := Dynamic_Node.Get_Value (The_Action.The_Target_Set);
if ((Dynamic_Value.Get_Kind (Sv) =
Dynamic_Value.Vocabulary_Word) and
(Dynamic_Value.Get_Kind (Tv) =
Dynamic_Value.Set_Of_Words)) then
Dynamic_Value.Append_To_Set (Tv,
Dynamic_Value.Get_Value (Sv));
Dynamic_Node.Set_Value (The_Action.The_Target_Set, Tv);
else
raise Bad_Argument_Type;
end if;
when Remove_From_Set_Of_Word =>
Dynamic_Node.Evaluate (The_Action.The_Out_Word);
Dynamic_Node.Evaluate (The_Action.The_Reduced_Set);
Sv := Dynamic_Node.Get_Value (The_Action.The_Out_Word);
Tv := Dynamic_Node.Get_Value (The_Action.The_Reduced_Set);
if ((Dynamic_Value.Get_Kind (Sv) =
Dynamic_Value.Vocabulary_Word) and
(Dynamic_Value.Get_Kind (Tv) =
Dynamic_Value.Set_Of_Words)) then
Dynamic_Value.Delete_From_Set
(Tv, Dynamic_Value.Get_Value (Sv));
Dynamic_Node.Set_Value (The_Action.The_Reduced_Set, Tv);
else
raise Bad_Argument_Type;
end if;
when Clear_Set_Of_Word =>
Dynamic_Node.Evaluate (The_Action.The_Set);
Tv := Dynamic_Node.Get_Value (The_Action.The_Set);
Dynamic_Value.Purge_Set (Tv);
Dynamic_Node.Set_Value (The_Action.The_Set, Tv);
when Quit_Action =>
raise End_Of_Program;
when others =>
null;
end case;
end Execute_Action;
procedure Add_Action (In_List : in out Acces_List;
The_Action : in Object) is
begin
Action_List.Add (In_List.all, The_Action);
end Add_Action;
procedure Evaluate (The_List : Acces_List) is
It : Action_List.Iterator;
begin
Action_List.Init (It, The_List.all);
while not Action_List.Done (It) loop
Evaluate_Action (Action_List.Value (It));
Action_List.Next (It);
end loop;
end Evaluate;
procedure Execute (The_List : Acces_List) is
It : Action_List.Iterator;
begin
Action_List.Init (It, The_List.all);
while not Action_List.Done (It) loop
Execute_Action (Action_List.Value (It));
Action_List.Next (It);
end loop;
end Execute;
end Compiler_Action;
nblk1=1e
nid=0
hdr6=3c
[0x00] rec0=19 rec1=00 rec2=01 rec3=042
[0x01] rec0=00 rec1=00 rec2=1e rec3=010
[0x02] rec0=1a rec1=00 rec2=12 rec3=050
[0x03] rec0=00 rec1=00 rec2=1d rec3=018
[0x04] rec0=12 rec1=00 rec2=0c rec3=052
[0x05] rec0=11 rec1=00 rec2=0f rec3=05e
[0x06] rec0=1a rec1=00 rec2=09 rec3=054
[0x07] rec0=01 rec1=00 rec2=13 rec3=022
[0x08] rec0=16 rec1=00 rec2=0a rec3=044
[0x09] rec0=14 rec1=00 rec2=04 rec3=004
[0x0a] rec0=15 rec1=00 rec2=0e rec3=03e
[0x0b] rec0=19 rec1=00 rec2=15 rec3=02a
[0x0c] rec0=16 rec1=00 rec2=07 rec3=00c
[0x0d] rec0=19 rec1=00 rec2=06 rec3=026
[0x0e] rec0=02 rec1=00 rec2=18 rec3=054
[0x0f] rec0=17 rec1=00 rec2=05 rec3=042
[0x10] rec0=12 rec1=00 rec2=10 rec3=02e
[0x11] rec0=1f rec1=00 rec2=0d rec3=022
[0x12] rec0=14 rec1=00 rec2=16 rec3=034
[0x13] rec0=1b rec1=00 rec2=0b rec3=00e
[0x14] rec0=1b rec1=00 rec2=1a rec3=09a
[0x15] rec0=02 rec1=00 rec2=17 rec3=030
[0x16] rec0=0f rec1=00 rec2=08 rec3=060
[0x17] rec0=15 rec1=00 rec2=19 rec3=042
[0x18] rec0=14 rec1=00 rec2=1c rec3=048
[0x19] rec0=0d rec1=00 rec2=11 rec3=012
[0x1a] rec0=13 rec1=00 rec2=03 rec3=006
[0x1b] rec0=00 rec1=00 rec2=1b rec3=07e
[0x1c] rec0=1f rec1=00 rec2=02 rec3=022
[0x1d] rec0=04 rec1=00 rec2=14 rec3=000
tail 0x215433e7286515d5e7199 0x42a00088462060003