|
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_048783, seg_048dfd
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000 └─ ⟦5a81ac88f⟧ »Space Info Vol 1« └─⟦this⟧ └─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000 └─ ⟦cfc2e13cd⟧ »Space Info Vol 2« └─⟦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; procedure Affiche (P : P_Cellule_Regle_Instruction) is begin case P.Typ is when Type_Regle => Text_Io.Put_Line (" une regle "); when Type_Instruction => Text_Io.Put ("une instruction: " & Expression_Fonction.Selecteur_Instruction'Image (P.Instruction.Typ) & " "); Nos_Chaines.Print_Line (P.Instruction.Name); end case; end Affiche; --------- 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); -- Text_Io.Put ("ajout de "); -- Affiche (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); -- Text_Io.Put ("ajout de "); -- Affiche (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; -- Text_Io.Put ("si condition est realise pointe vers "); -- Affiche (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; -- Text_Io.Put (" sinon pointe vers "); -- Affiche (Head); else Current_Cell.Si_Condition := Head; -- Text_Io.Put ("si condition est realise pointe vers "); -- Affiche (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); -- Text_Io.Put ("le debut du bloc pointe vers "); -- Affiche (Head); L := Head; -- Test_The_Bloc (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 differents 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 identiques 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 Text_Io.Put_Line (Selecteur_Regle_Instruction'Image (List.Typ)); case List.Typ is when Type_Instruction => Text_Io.Put_Line (Expression_Fonction. Selecteur_Instruction'Image (List.Instruction.Typ)); case List.Instruction.Typ is when Expression_Fonction.Type_Function => Text_Io.Put_Line ("go to execute function"); Expression_Fonction.Execute_Function (List.Instruction); Text_Io.Put_Line ("execution is done"); when Expression_Fonction.Type_Variable => Text_Io.Put_Line ("go to evaluate"); Tmp := Expression_Fonction.Evaluate (List.Instruction.Tree_To_Evalue); Interface_Structure.Put_Value_In_Counter (List.Instruction.Name, Tmp); Text_Io.Put_Line ("affectation is done"); end case; when Type_Regle => Text_Io.Put_Line ("go to evalue the condition"); if Condition.Evaluate (List.Condition_A_Realiser) then Text_Io.Put_Line ("condition is realise"); Do_The (List.Si_Condition); else Text_Io.Put_Line ("condition is not realise"); Do_The (List.Sinon); end if; end case; List := List.Suivant; end loop; end Do_The; end Traduction_Scenario;
nblk1=22 nid=20 hdr6=40 [0x00] rec0=1f rec1=00 rec2=01 rec3=04a [0x01] rec0=1e rec1=00 rec2=11 rec3=02e [0x02] rec0=05 rec1=00 rec2=07 rec3=04e [0x03] rec0=1f rec1=00 rec2=06 rec3=024 [0x04] rec0=1a rec1=00 rec2=1a rec3=07c [0x05] rec0=21 rec1=00 rec2=22 rec3=008 [0x06] rec0=1a rec1=00 rec2=0a rec3=010 [0x07] rec0=1d rec1=00 rec2=1e rec3=00a [0x08] rec0=01 rec1=00 rec2=1b rec3=046 [0x09] rec0=19 rec1=00 rec2=1f rec3=00a [0x0a] rec0=00 rec1=00 rec2=03 rec3=002 [0x0b] rec0=15 rec1=00 rec2=10 rec3=046 [0x0c] rec0=1a rec1=00 rec2=0c rec3=036 [0x0d] rec0=0b rec1=00 rec2=17 rec3=08e [0x0e] rec0=1e rec1=00 rec2=0b rec3=00a [0x0f] rec0=1d rec1=00 rec2=04 rec3=038 [0x10] rec0=14 rec1=00 rec2=08 rec3=014 [0x11] rec0=1b rec1=00 rec2=18 rec3=06c [0x12] rec0=1a rec1=00 rec2=09 rec3=016 [0x13] rec0=1a rec1=00 rec2=13 rec3=066 [0x14] rec0=1a rec1=00 rec2=14 rec3=046 [0x15] rec0=03 rec1=00 rec2=1c rec3=05a [0x16] rec0=13 rec1=00 rec2=02 rec3=05c [0x17] rec0=17 rec1=00 rec2=0d rec3=00e [0x18] rec0=17 rec1=00 rec2=12 rec3=034 [0x19] rec0=1c rec1=00 rec2=16 rec3=034 [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 0x2174cb274865993e12af4 0x42a00088462060003 Free Block Chain: 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 ┆