|
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 - download
Length: 35840 (0x8c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Traduction_Scenario, seg_0499fe, seg_049e4e
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Variables;
with Nos_Piles;
with Error;
with Interface_Structure;
with Text_Io;
package body Traduction_Scenario is
Null_Access : P_Cellule_Regle_Instruction := null;
package Save_Cellule is new Nos_Piles
(P_Cellule_Regle_Instruction, Null_Access);
package Save_Liste is new Nos_Piles
(P_Cellule_Regle_Instruction, Null_Access);
package Save_Head is new Nos_Piles
(P_Cellule_Regle_Instruction, Null_Access);
Buffer_Liste : Save_Liste.Objet;
Buffer_Cell : Save_Cellule.Objet;
Buffer_Head : Save_Head.Objet;
Current_List : P_Cellule_Regle_Instruction;
Current_Cell : P_Cellule_Regle_Instruction;
Is_Start_List : Boolean;
-- arbre d'evaluation des expressions
Current_Condition_Tree : Condition.P_Node;
Current_Fonction_Tree : Expression_Fonction.P_Node;
-- variables necessaires a la construction d'un antecedant
Parameter_Tab : Condition.T_Tab_Of_Parameter;
Parameter_Tab1 : Condition.T_Tab_Of_Parameter;
Comparateur : Condition.T_Comparateur;
Tab2_Is_Use : Boolean;
Action : Boolean;
Expression_Courante : Condition.T_Expression;
-- variables necessaires a la gestion des generiques
Level : Integer := 0;
Number_Of_Condition : Integer := 1;
Generic_Control : Variables.Generic_Control := (others => 0);
Can_Use_Sortie_At_Level : Integer := 0;
-- index dans les tableaux de parameters
Index : Positive;
Index1 : Positive;
----- tue les variables generiques d un niveau passe en parametre -----
procedure Kill_Generic (L : Integer) is
begin
for I in Variables.T_Generic loop
if Generic_Control (I) = L then
Generic_Control (I) := 0;
end if;
end loop;
if Can_Use_Sortie_At_Level = L then
Can_Use_Sortie_At_Level := 0;
end if;
end Kill_Generic;
--------- construction d'un bloc de regles ou instruction -------------
procedure Ajouter_Current_Cell is
begin
if Current_List /= null then
Current_List.Suivant := Current_Cell;
Current_List := Current_List.Suivant;
else
Current_List := Current_Cell;
end if;
end Ajouter_Current_Cell;
procedure Make_Regle is
begin
Level := Level + 1;
-------------------------------------------
Text_Io.Put_Line ("level is now: " & Integer'Image (Level));
Text_Io.Put_Line ("----------------------------------------");
Number_Of_Condition := 0;
Index := 1;
Tab2_Is_Use := False;
if not Is_Start_List then
Ajouter_Current_Cell;
end if;
Save_Liste.Add (Buffer_Liste, Current_List);
Current_Cell := new Cellule_Regle_Instruction (Type_Regle);
if Is_Start_List then
Save_Head.Add (Buffer_Head, Current_Cell);
Is_Start_List := False;
end if;
Save_Cellule.Add (Buffer_Cell, Current_Cell);
Current_List := null;
Is_Start_List := True;
end Make_Regle;
procedure Make_Instruction is
begin
if not Is_Start_List then
Ajouter_Current_Cell;
end if;
Current_Cell := new Cellule_Regle_Instruction (Type_Instruction);
if Is_Start_List then
Save_Head.Add (Buffer_Head, Current_Cell);
Is_Start_List := False;
end if;
end Make_Instruction;
procedure Break_Alors is
begin
null;
end Break_Alors;
procedure Break_Sinon is
Head : P_Cellule_Regle_Instruction;
begin
Ajouter_Current_Cell;
Save_Cellule.Delete (Buffer_Cell, Current_Cell);
Save_Head.Delete (Buffer_Head, Head);
Current_Cell.Si_Condition := Head;
Current_List := null;
Is_Start_List := True;
Save_Cellule.Add (Buffer_Cell, Current_Cell);
end Break_Sinon;
procedure Break_Finsi is
Head : P_Cellule_Regle_Instruction;
begin
Ajouter_Current_Cell;
Save_Head.Delete (Buffer_Head, Head);
Save_Cellule.Delete (Buffer_Cell, Current_Cell);
if Current_Cell.Si_Condition /= null then
Current_Cell.Sinon := Head;
else
Current_Cell.Si_Condition := Head;
end if;
Save_Liste.Delete (Buffer_Liste, Current_List);
Kill_Generic (Level);
Level := Level - 1;
end Break_Finsi;
procedure Test_The_Bloc (L : P_Cellule_Regle_Instruction);
procedure Break_End_Of_Bloc (L : in out P_Cellule_Regle_Instruction) is
Head : P_Cellule_Regle_Instruction;
begin
Ajouter_Current_Cell;
Save_Head.Delete (Buffer_Head, Head);
L := Head;
end Break_End_Of_Bloc;
procedure Start_Bloc is
begin
Current_Cell := Null_Access;
Current_List := Null_Access;
Is_Start_List := True;
end Start_Bloc;
------------- construction expression numerique ----------------------
procedure New_Numeric_Function (Nom : Nos_Chaines.String_Text) is
use Expression_Fonction;
Tmp : T_Instruction (Type_Variable);
begin
if Wich_Type (Nom) /= Compteur then
Error.Semantic (Error.Affectation_Incorrecte);
end if;
Nos_Chaines.Copy (Tmp.Name, Nom);
Current_Cell.Instruction := Tmp;
end New_Numeric_Function;
procedure Add_The_New_Numeric_Function
(P : Expression_Fonction.T_Numeric_Function) is
begin
Current_Cell.Instruction.Tree_To_Evalue := P;
Text_Io.Put_Line ("------------------------------------------");
Text_Io.Put (" go to modifie " &
Expression_Fonction.Selecteur_Instruction'Image
(Current_Cell.Instruction.Typ) & " ");
Nos_Chaines.Print_Line (Current_Cell.Instruction.Name);
Text_Io.Put_Line ("------------------------------------------");
end Add_The_New_Numeric_Function;
---------- construction fonction predefinie ------------------------
procedure Name_Of_Function (Nom : Nos_Chaines.String_Text) is
use Expression_Fonction;
Tmp : T_Instruction (Type_Function);
begin
Index := 1;
Current_Cell.Instruction := Tmp;
Nos_Chaines.Copy (Current_Cell.Instruction.Name, Nom);
end Name_Of_Function;
procedure Add_Function_Parameter
(P : Nos_Chaines.String_Text; Is_Text : Boolean := False) is
use Expression_Fonction;
Current_Typ : T_Parameter;
begin
if Is_Text then
Current_Typ := Texte;
else
Current_Typ := Wich_Type (P);
if Current_Typ = Unknown then
if Index > 1 then
if Current_Cell.Instruction.Parameters (Index - 1).Typ =
Etat then
Current_Typ := Texte;
else
Error.Semantic (Error.Variable_Non_Definie);
end if;
else
Error.Semantic (Error.Variable_Non_Definie);
end if;
end if;
end if;
if Index > 1 then
if not Compatible
(Current_Cell.Instruction.Parameters (Index - 1).Typ,
Current_Typ) then
if not (Is_Text and Nos_Chaines.Equal
(Current_Cell.Instruction.Name,
Nos_Chaines.Infinite_String.Value
("modifierdescription"))) then
Error.Semantic (Error.Incompatibilite_Condition);
end if;
end if;
end if;
if Variables.Is_Generic (P) then
if Generic_Control (Variables.Get_Index (P)) > Level then
Error.Semantic (Error.Generique_Non_Visible);
-- le generique n'est pas visible
end if;
end if;
if Current_Typ = Sortie then
if Can_Use_Sortie_At_Level = 0 or
Can_Use_Sortie_At_Level > Level then
Error.Semantic (Error.Sortie_Non_Visible);
end if;
end if;
Current_Cell.Instruction.Parameters (Index).Typ := Current_Typ;
Nos_Chaines.Copy (Current_Cell.Instruction.Parameters (Index).Value, P);
Index := Index + 1;
end Add_Function_Parameter;
procedure End_Of_Function is
I : Integer := 1;
begin
Current_Cell.Instruction.Number_Of_Parameters := Index - 1;
------------------------------------------------------------
Text_Io.Put_Line (" ");
Text_Io.Put_Line ("----------------------------------------");
Text_Io.Put ("LEVEL " & Integer'Image (Level) & " ");
Nos_Chaines.Print (Current_Cell.Instruction.Name);
loop
Nos_Chaines.Print (Current_Cell.Instruction.Parameters (I).Value);
Text_Io.Put
(Expression_Fonction.T_Parameter'Image
(Current_Cell.Instruction.Parameters (I).Typ) & " ");
I := I + 1;
exit when I > Current_Cell.Instruction.Number_Of_Parameters;
end loop;
Text_Io.Put_Line (" ");
Text_Io.Put_Line ("----------------------------------------");
end End_Of_Function;
-------------------- construction d'un antecedent ----------------------
function Make_New_Action return Condition.T_Expression is
use Condition;
New_Action : T_Expression (Type_Action);
I : Integer := 1;
begin
Copy_Tab (New_Action.Parameters, Parameter_Tab);
New_Action.Number_Of_Parameters := Index - 1;
----------------------------------------------------------------
Text_Io.Put ("ACTION : ");
loop
Nos_Chaines.Print (New_Action.Parameters (I).Value);
Text_Io.Put
(Condition.T_Parameter'Image (New_Action.Parameters (I).Typ) &
" ");
I := I + 1;
exit when I > New_Action.Number_Of_Parameters;
end loop;
Text_Io.Put_Line (" ");
Text_Io.Put_Line ("----------------------------------------");
return New_Action;
end Make_New_Action;
function Make_New_Recherche return Condition.T_Expression is
use Condition;
New_Recherche : T_Expression (Type_Recherche);
I : Integer := 1;
begin
Copy_Tab (New_Recherche.Parameters, Parameter_Tab);
New_Recherche.Number_Of_Parameters := Index - 1;
Text_Io.Put ("RECHERCHE : ");
loop
Nos_Chaines.Print (New_Recherche.Parameters (I).Value);
Text_Io.Put
(Condition.T_Parameter'Image (New_Recherche.Parameters (I).Typ) &
" ");
I := I + 1;
exit when I > New_Recherche.Number_Of_Parameters;
end loop;
Text_Io.Put_Line (" ");
Text_Io.Put_Line ("----------------------------------------");
return New_Recherche;
end Make_New_Recherche;
function Make_New_Egalite return Condition.T_Expression is
use Condition;
New_Egalite : T_Expression (Type_Egalite);
I : Integer := 1;
begin
Copy_Tab (New_Egalite.Member1, Parameter_Tab1);
Copy_Tab (New_Egalite.Member2, Parameter_Tab);
New_Egalite.Size_Of_Member1 := Index1 - 1;
New_Egalite.Size_Of_Member2 := Index - 1;
if Index1 = Index then
if Parameter_Tab1 (Index - 1).Typ = Condition.Position then
if Parameter_Tab (Index - 1).Typ /= Condition.Position then
Error.Semantic (Error.Incompatibilite_Egalite);
end if; -- on peut comparer les positions de deux variables de type
else
Index := 1;
while Index < Index1 loop
if Parameter_Tab1 (Index).Typ /=
Parameter_Tab (Index).Typ then
Error.Semantic (Error.Incompatibilite_Egalite);
end if;-- type de variables et type d'attributs doivent etre iden
Index := Index + 1;
end loop;
end if;
else
if Parameter_Tab1 (Index1 - 1).Typ /= Condition.Position and
Parameter_Tab (1).Typ /= Condition.Lieu then
Error.Semantic (Error.Incompatibilite_Egalite);
end if;
end if;
I := 1;
Text_Io.Put_Line ("EGALITE : ");
Text_Io.Put_Line ("MEMBRE1 :");
loop
Nos_Chaines.Print (New_Egalite.Member1 (I).Value);
Text_Io.Put
(Condition.T_Parameter'Image (New_Egalite.Member1 (I).Typ) &
" ");
I := I + 1;
exit when I > New_Egalite.Size_Of_Member1;
end loop;
I := 1;
Text_Io.Put_Line (" ");
Text_Io.Put_Line ("MEMBRE2 :");
loop
Nos_Chaines.Print (New_Egalite.Member2 (I).Value);
Text_Io.Put
(Condition.T_Parameter'Image (New_Egalite.Member2 (I).Typ) &
" ");
I := I + 1;
exit when I > New_Egalite.Size_Of_Member2;
end loop;
Text_Io.Put_Line (" ");
Text_Io.Put_Line ("----------------------------------------");
return New_Egalite;
end Make_New_Egalite;
function Make_New_Comparaison return Condition.T_Expression is
use Condition;
New_Comparaison : T_Expression (Type_Comparaison);
begin
New_Comparaison.Id := Parameter_Tab1 (1).Value;
New_Comparaison.Operator := Comparateur;
New_Comparaison.Value := Integer'Value
(Nos_Chaines.Infinite_String.Image
(Parameter_Tab (1).Value));
--------------------------------------------------------------
Text_Io.Put_Line ("COMPARAISON :");
Nos_Chaines.Print (New_Comparaison.Id);
Text_Io.Put (Condition.T_Comparateur'Image (New_Comparaison.Operator));
Text_Io.Put (" " & Integer'Image (New_Comparaison.Value));
Text_Io.Put_Line (" ");
Text_Io.Put_Line ("----------------------------------------");
return New_Comparaison;
end Make_New_Comparaison;
procedure Add_Condition_Parameter
(P : Nos_Chaines.String_Text; Is_Number : Boolean := False) is
use Condition;
use Variables;
Current_Typ : T_Parameter;
One_Generic_Yet : Boolean;
begin
------------- TYPE DU PARAMETERE ------------------------------
if Is_Number then
Current_Typ := Number;
else
Current_Typ := Wich_Type (P);
if Current_Typ = Unknown then
if not Is_Comparateur (P) then
if Index > 1 then
if Parameter_Tab (Index - 1).Typ = Etat then
Current_Typ := Texte;
else
Error.Semantic (Error.Variable_Non_Definie);
end if;
else
Error.Semantic (Error.Variable_Non_Definie);
end if;
end if;
end if;
end if;
------------- INSTANCIATION DE LA VARIABLE SORTIE ? -----------------
if Current_Typ = Reliea or Current_Typ = Dans or
Current_Typ = Sortie then
Can_Use_Sortie_At_Level := Level;
Text_Io.Put_Line ("----------------------------------------");
Text_Io.Put (" Can_Use_Sortie_At_Level");
Text_Io.Put (Integer'Image (Can_Use_Sortie_At_Level));
Text_Io.Put_Line (" ");
Text_Io.Put_Line ("----------------------------------------");
end if;
----------------------------- GESTION DES GENERIQUES --------------------
if Is_Generic (P) then
if Generic_Control (Get_Index (P)) = 0 then
-- la variable n'a pas ete declaree
One_Generic_Yet := False;
for I in Generic_Control'Range loop
if Generic_Control (I) > 0 then
One_Generic_Yet := True;
end if;
end loop;
if One_Generic_Yet then
Error.Semantic (Error.Generique_Double);
else
if Number_Of_Condition = 0 then
-- on est au premier antecedant
if Parameter_Tab (1).Typ = Verbe then
-- on a bien une action
Generic_Control (Get_Index (P)) := Level;
Text_Io.Put ("GENERIQUE:" &
T_Generic'Image (Get_Index (P)) &
" is declare at level " &
Integer'Image (Level));
Text_Io.Put_Line (" ");
Text_Io.Put_Line
("----------------------------------------");
else
Error.Semantic (Error.Generique_Mal_Declare);
end if;
else
Error.Semantic (Error.Generique_Mal_Declare);
-- on ne peut declarer un generique que dans le premier antecedant de type action
end if;
end if;
else
if Generic_Control (Get_Index (P)) > Level then
Error.Semantic (Error.Generique_Non_Visible);
-- le generique n'est pas visible
end if;
if Number_Of_Condition = 0 then
Error.Semantic (Error.Generique_Double);
-- un generique est deja utilise
end if;
end if;
end if;
if Is_Comparateur (P) then
-------------------- MISE EN FORME POUR LES EVALUATIONS -----------------
Comparateur := To_Type_Comparateur (P);
Copy_Tab (Parameter_Tab1, Parameter_Tab);
Tab2_Is_Use := True;
Index1 := Index;
Index := 1;
else
-------------------- VERIFICATION DE LA COMPATIBILITE ET SAUVEGARDE -----
if Index > 1 then
if not Compatible
(Parameter_Tab (Index - 1).Typ, Current_Typ) then
Error.Semantic (Error.Incompatibilite_Instruction);
end if;
else
if Current_Typ = Verbe then
Action := True;
else
Action := False;
end if;
end if;
if Current_Typ = Verbe or Current_Typ = Preposition then
Nos_Chaines.Copy (Parameter_Tab (Index).Value,
Interface_Structure.Get_Signification (P));
else
Nos_Chaines.Copy (Parameter_Tab (Index).Value, P);
end if;
Parameter_Tab (Index).Typ := Current_Typ;
Index := Index + 1;
end if;
end Add_Condition_Parameter;
procedure End_Condition_Parameter is
use Condition;
begin
Number_Of_Condition := Number_Of_Condition + 1;
if Action then
Expression_Courante := Make_New_Action;
elsif Tab2_Is_Use then
if Parameter_Tab1 (1).Typ = Compteur then
Expression_Courante := Make_New_Comparaison;
else
Expression_Courante := Make_New_Egalite;
end if;
else
Expression_Courante := Make_New_Recherche;
end if;
Index := 1;
Tab2_Is_Use := False;
end End_Condition_Parameter;
function Get_Condition return Condition.T_Expression is
begin
return Expression_Courante;
end Get_Condition;
procedure Add_The_New_Condition (P : Condition.T_Condition) is
begin
Current_Cell.Condition_A_Realiser := P;
end Add_The_New_Condition;
procedure Test_The_Bloc (L : P_Cellule_Regle_Instruction) is
List : P_Cellule_Regle_Instruction := L;
begin
while List /= null loop
Text_Io.Put (Selecteur_Regle_Instruction'Image (List.Typ));
case List.Typ is
when Type_Instruction =>
Text_Io.Put
(" " & Expression_Fonction.Selecteur_Instruction'Image
(List.Instruction.Typ) & " ");
Nos_Chaines.Print_Line (List.Instruction.Name);
when Type_Regle =>
Text_Io.Put_Line (" ");
Text_Io.Put_Line ("if condition");
Test_The_Bloc (List.Si_Condition);
Text_Io.Put_Line ("else");
Test_The_Bloc (List.Sinon);
Text_Io.Put_Line ("fin si");
end case;
List := List.Suivant;
end loop;
end Test_The_Bloc;
---------------- parcours d'un bloc de regles et instruction --------------------
procedure Do_The (L : P_Cellule_Regle_Instruction) is
Tmp : Integer;
List : P_Cellule_Regle_Instruction := L;
begin
while List /= null loop
case List.Typ is
when Type_Instruction =>
case List.Instruction.Typ is
when Expression_Fonction.Type_Function =>
Expression_Fonction.Execute_Function
(List.Instruction);
when Expression_Fonction.Type_Variable =>
Tmp := Expression_Fonction.Evaluate
(List.Instruction.Tree_To_Evalue);
Interface_Structure.Put_Value_In_Counter
(List.Instruction.Name, Tmp);
end case;
when Type_Regle =>
if Condition.Evaluate (List.Condition_A_Realiser) then
Do_The (List.Si_Condition);
else
Do_The (List.Sinon);
end if;
end case;
List := List.Suivant;
end loop;
end Do_The;
end Traduction_Scenario;
nblk1=22
nid=22
hdr6=30
[0x00] rec0=1f rec1=00 rec2=01 rec3=052
[0x01] rec0=1e rec1=00 rec2=1c rec3=036
[0x02] rec0=20 rec1=00 rec2=11 rec3=072
[0x03] rec0=22 rec1=00 rec2=07 rec3=00e
[0x04] rec0=1d rec1=00 rec2=1a rec3=056
[0x05] rec0=1b rec1=00 rec2=1d rec3=058
[0x06] rec0=16 rec1=00 rec2=0e rec3=01c
[0x07] rec0=19 rec1=00 rec2=05 rec3=032
[0x08] rec0=18 rec1=00 rec2=15 rec3=018
[0x09] rec0=16 rec1=00 rec2=19 rec3=086
[0x0a] rec0=1e rec1=00 rec2=16 rec3=012
[0x0b] rec0=1c rec1=00 rec2=12 rec3=024
[0x0c] rec0=13 rec1=00 rec2=0d rec3=072
[0x0d] rec0=1e rec1=00 rec2=02 rec3=006
[0x0e] rec0=16 rec1=00 rec2=14 rec3=02e
[0x0f] rec0=1c rec1=00 rec2=13 rec3=012
[0x10] rec0=19 rec1=00 rec2=08 rec3=014
[0x11] rec0=13 rec1=00 rec2=18 rec3=010
[0x12] rec0=17 rec1=00 rec2=04 rec3=03c
[0x13] rec0=16 rec1=00 rec2=0b rec3=076
[0x14] rec0=1f rec1=00 rec2=0c rec3=018
[0x15] rec0=17 rec1=00 rec2=10 rec3=040
[0x16] rec0=17 rec1=00 rec2=1f rec3=006
[0x17] rec0=11 rec1=00 rec2=1e rec3=000
[0x18] rec0=01 rec1=00 rec2=1e rec3=000
[0x19] rec0=0d rec1=00 rec2=22 rec3=000
[0x1a] rec0=07 rec1=00 rec2=19 rec3=06e
[0x1b] rec0=16 rec1=00 rec2=15 rec3=054
[0x1c] rec0=16 rec1=00 rec2=05 rec3=02a
[0x1d] rec0=00 rec1=00 rec2=0e rec3=01c
[0x1e] rec0=11 rec1=00 rec2=0f rec3=00e
[0x1f] rec0=09 rec1=00 rec2=1d rec3=000
[0x20] rec0=8c rec1=00 rec2=00 rec3=000
[0x21] rec0=00 rec1=00 rec2=3c rec3=785
tail 0x21547136c86606afd1bad 0x42a00088462060003
Free Block Chain:
0x22: 0000 00 0f 03 fc 00 30 20 20 20 20 20 20 20 20 20 20 ┆ 0 ┆
0xf: 0000 00 09 00 17 80 14 5f 69 6f 2e 70 75 74 5f 6c 69 ┆ _io.put_li┆
0x9: 0000 00 17 03 fc 80 0b 28 49 29 2e 56 61 6c 75 65 29 ┆ (I).Value)┆
0x17: 0000 00 03 03 fc 80 01 3b 01 00 00 00 00 46 20 20 20 ┆ ; F ┆
0x3: 0000 00 1b 00 04 80 01 20 01 6f 6e 2e 53 65 6c 65 63 ┆ on.Selec┆
0x1b: 0000 00 0a 00 4c 80 23 20 20 20 54 65 78 74 5f 49 6f ┆ L # Text_Io┆
0xa: 0000 00 06 00 1e 80 10 20 41 66 66 69 63 68 65 20 28 ┆ Affiche (┆
0x6: 0000 00 20 03 fc 80 13 67 6c 65 5f 49 6e 73 74 72 75 ┆ gle_Instru┆
0x20: 0000 00 21 00 12 80 0f 65 61 6b 5f 45 6e 64 5f 4f 66 ┆ ! eak_End_Of┆
0x21: 0000 00 00 00 0b 80 08 65 61 64 2c 20 48 65 61 08 00 ┆ ead, Hea ┆