|
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: 76369 (0x12a51)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦2879e02b7⟧
└─⟦this⟧
with Text_Io,Lexical,Nom_Jeu,Les_Actions,Les_Definitions,Les_Presentations;
with Les_Liaisons,Les_Anims_Globales,Les_Anims_Locales,Fin_Jeu,Erreur;
with Verbs_Dictionary;
use Text_Io;
procedure Main2 is
Nomf : constant String := "Ex_Jeu";
Dict : Verbs_Dictionary.Object;
begin
Lexical.Init( Nomf );
Lexical.Next;
Nom_jeu.Parse;
Verbs_Dictionary.Create(Dict);
Les_Actions.Parse(dict);
Verbs_Dictionary.Dump(Dict);
Les_Definitions.Parse;
Les_Presentations.Parse;
Les_Liaisons.Parse;
Les_Anims_Globales.Parse;
Les_Anims_Locales.Parse;
Fin_Jeu.Parse;
if Not Erreur.Is_Any then
Text_Io.Put("Ok");
else
Text_Io.Put("pas Ok");
end if;
Lexical.Close;
Exception
when Erreur.Erreur_Syntaxe => Text_Io.Put_Line (" -- Erreur Fatale");
Text_Io.Put_Line ("Bye, bye...");
Verbs_Dictionary.Destroy(dict);
when Verbs_Dictionary.Duplicate_Value => Text_Io.Put("Lg:");
Text_Io.Put(Natural'Image(Lexical.Get_Line));
Text_Io.Put(" Cl:");
Text_Io.Put(Natural'Image(Lexical.Get_Column));
-- when others => Text_Io.Put_Line ("Erreur inconnue");
end Main2;
With Lexical,Token_List,Verbs_Dictionary,Erreur,Synonymes,Text_Io;
Use Lexical,Token_List;
Package body Actions is
Action_First:Token_List.Object := Make(Id);
Procedure Action (dict:Verbs_Dictionary.Object) is
Begin
if Lexical.Get_Token = Id then
-- if Verbs_Dictionary.Exist(Lexical.Get_Value,dict) then
-- Erreur.Parse("Verbe deja existant");
-- else
Verbs_Dictionary.Add_New(Lexical.Get_Value,dict);
-- end if;
Lexical.Next;
Synonymes.Parse (dict);
else
Erreur.Parse("Manque un verbe");
end if;
End Action;
Procedure Parse (dict:Verbs_Dictionary.Object) is
Begin
Action (dict);
while Is_In(Lexical.Get_Token,Action_First) loop
Action (dict);
end loop;
End Parse;
End Actions;
with unchecked_deallocation;
Package body Binary_Trees_Pkg is
--| Efficient implementation of binary trees.
----------------------------------------------------------------------------
-- Local Operations --
----------------------------------------------------------------------------
procedure Free_Node is
new unchecked_deallocation(Node, Node_Ptr);
procedure Free_Tree is
new unchecked_deallocation(Tree_Header, Tree);
procedure Free_Iterator is
new unchecked_deallocation(Iterator_Record, Iterator);
----------------------------------------------------------------------------
-- Visible Operations --
----------------------------------------------------------------------------
Function Create --| Return an empty tree.
return Tree is
begin
return new Tree_Header'(0, Null);
end Create;
----------------------------------------------------------------------------
Procedure Insert_Node(
V: Value_Type;
N: in out Node_Ptr;
Found: out boolean;
Duplicate: out Value_Type
)
is
D: integer;
begin
Found := False;
if N = null then
N := new Node'(V, Null, Null);
else
D := Difference(V, N.Value);
if D < 0 then
Insert_Node(V, N.Less, Found, Duplicate);
elsif D > 0 then
Insert_Node(V, N.More, Found, Duplicate);
else
Found := True;
Duplicate := N.Value;
end if;
end if;
end Insert_Node;
Procedure Replace_Node(
V: Value_Type;
N: in out Node_Ptr;
Found: out boolean;
Duplicate: out Value_Type
)
is
D: integer;
begin
Found := False;
if N = null then
N := new Node'(V, Null, Null);
else
D := Difference(V, N.Value);
if D < 0 then
Replace_Node(V, N.Less, Found, Duplicate);
elsif D > 0 then
Replace_Node(V, N.More, Found, Duplicate);
else
Found := True;
Duplicate := N.Value;
N.Value := V;
end if;
end if;
end Replace_Node;
Procedure Insert( --| Insert a value into a tree.
V: Value_Type; --| Value to be inserted
T: Tree --| Tree to contain the new value
) --| Raises: Duplicate_Value, Invalid_Tree.
is
Found: boolean;
Duplicate: Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Insert_Node(V, T.Root, Found, Duplicate);
if Found then
raise Duplicate_Value;
end if;
T.Count := T.Count + 1;
end Insert;
Procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean;
Duplicate: out Value_Type
) --| Raises: Invalid_Tree.
is
was_Found: boolean;
begin
if T = null then
raise Invalid_Tree;
end if;
Insert_Node(V, T.Root, was_Found, Duplicate);
Found := was_Found;
if not was_Found then
T.Count := T.Count + 1;
end if;
end Insert_if_Not_Found;
procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean; --| Becomes True iff L already in tree
Old_Value: out Value_Type --| the duplicate value, if there is one
) --| Raises: Invalid_Tree.
is
was_Found: boolean;
Duplicate: Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Replace_Node(V, T.Root, was_Found, Duplicate);
Found := was_Found;
if was_Found then
Old_Value := Duplicate;
else
T.Count := T.Count + 1;
end if;
end Replace_if_Found;
----------------------------------------------------------------------------
procedure Destroy_Nodes(
N: in out Node_Ptr
) is
begin
if N /= null then
Destroy_Nodes(N.Less);
Destroy_Nodes(N.More);
Free_Node(N);
end if;
end Destroy_Nodes;
procedure Destroy( --| Free space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
) is
begin
if T /= Null then
Destroy_Nodes(T.Root);
Free_Tree(T);
end if;
end Destroy;
----------------------------------------------------------------------------
procedure Destroy_Deep( --| Free all space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
)
is
procedure Destroy_Nodes(
N: in out node_Ptr
) is
begin
if N /= null then
Free_Value(N.Value);
Destroy_Nodes(N.Less);
Destroy_Nodes(N.More);
Free_Node(N);
end if;
end Destroy_Nodes;
begin
if T /= Null then
Destroy_Nodes(T.Root);
Free_Tree(T);
end if;
end Destroy_Deep;
----------------------------------------------------------------------------
Function Balanced_Tree(
Count: natural
) return Tree
is
new_Tree: Tree := Create;
procedure subtree(Count: natural; N: in out Node_Ptr)
is
new_Node: Node_Ptr;
begin
if Count = 1 then
new_Node := new Node'(next_Value, Null, Null);
elsif Count > 1 then
new_node := new Node;
subtree(Count/2, new_Node.Less); -- Half are less
new_Node.Value := next_Value; -- Median value
subtree(Count - Count/2 - 1, new_Node.More); -- Other half are more
end if;
N := new_Node;
end subtree;
begin
new_Tree.Count := Count;
subtree(Count, new_Tree.Root);
return new_Tree;
end Balanced_Tree;
----------------------------------------------------------------------------
Function Copy_Tree(
T: Tree
) return Tree
is
I: Iterator;
function next_Val return Value_type
is
V: Value_Type;
begin
Next(I, V);
return copy_Value(V);
end next_Val;
function copy_Balanced is new Balanced_Tree(next_Val);
begin
I := Make_Iter(T); -- Will raise Invalid_Tree if necessary
return copy_Balanced(Size(T));
end Copy_Tree;
----------------------------------------------------------------------------
Function Is_Empty( --| Check for an empty tree.
T: Tree
) return boolean is
begin
return T = Null or else T.Root = Null;
end Is_Empty;
----------------------------------------------------------------------------
procedure Find_Node(
V: Value_Type; --| Value to be located
N: Node_Ptr; --| subtree to be searched
Match: out Value_Type; --| Matching value found in the tree
Found: out Boolean --| TRUE iff a match was found
)
is
D: integer;
begin
if N = null then
Found := False;
return;
end if;
D := Difference(V, N.Value);
if D < 0 then
Find_Node(V, N.Less, Match, Found);
elsif D > 0 then
Find_Node(V, N.More, Match, Found);
else
Match := N.Value;
Found := TRUE;
end if;
end Find_Node;
Function Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Value_Type --| Raises: Not_Found.
is
Found: Boolean;
Match: Value_Type;
begin
if T = Null then
raise Invalid_Tree;
end if;
Find_Node(V, T.Root, Match, Found);
if Found then
return Match;
else
raise Not_Found;
end if;
end Find;
Procedure Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree; --| Tree to be searched
Found: out Boolean; --| TRUE iff a match was found
Match: out Value_Type --| Matching value found in the tree
) is
begin
if T = Null then
raise Invalid_Tree;
end if;
Find_Node(V, T.Root, Match, Found);
end Find;
----------------------------------------------------------------------------
function is_Found( --| Check a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Boolean
is
Found: Boolean;
Match: Value_Type;
begin
if T = Null then
raise Invalid_Tree;
end if;
Find_Node(V, T.Root, Match, Found);
return Found;
end is_Found;
----------------------------------------------------------------------------
function Size( --| Return the count of values in T.
T: Tree --| a tree
) return natural is
begin
if T = Null then
Return 0;
else
Return T.Count;
end if;
end Size;
----------------------------------------------------------------------------
procedure Visit(
T: Tree;
Order: Scan_Kind
) is
procedure visit_Inorder(N: Node_Ptr) is
begin
if N.Less /= null then
visit_Inorder(N.Less);
end if;
Process(N.Value);
if N.More /= null then
visit_Inorder(N.More);
end if;
end visit_Inorder;
procedure visit_preorder(N: Node_Ptr) is
begin
Process(N.Value);
if N.Less /= null then
visit_preorder(N.Less);
end if;
if N.More /= null then
visit_preorder(N.More);
end if;
end visit_preorder;
procedure visit_postorder(N: Node_Ptr) is
begin
if N.Less /= null then
visit_postorder(N.Less);
end if;
if N.More /= null then
visit_postorder(N.More);
end if;
Process(N.Value);
end visit_postorder;
begin
if T = Null then
raise Invalid_Tree;
else
case Order is
when inorder =>
Visit_Inorder(T.Root);
when preorder =>
Visit_preorder(T.Root);
when postorder =>
Visit_postorder(T.Root);
end case;
end if;
end Visit;
----------------------------------------------------------------------------
function subtree_Iter( --| Create an iterator over a subtree
N: Node_Ptr;
P: Iterator
) return Iterator is
begin
if N = Null then
return new Iterator_Record'(State => Done, Parent => P, subtree => N);
elsif N.Less = Null then
return new Iterator_Record'(State => Middle, Parent => P, subtree => N);
else
return new Iterator_Record'(State => Left, Parent => P, subtree => N);
end if;
end subtree_Iter;
function Make_Iter( --| Create an iterator over a tree
T: Tree
) return Iterator is
begin
if T = Null then
raise Invalid_Tree;
end if;
return subtree_Iter(T.Root, Null);
end Make_Iter;
----------------------------------------------------------------------------
function More( --| Test for exhausted iterator
I: Iterator --| The iterator to be tested
) return boolean is
begin
if I = Null then
return False;
elsif I.Parent = Null then
return I.State /= Done and I.subtree /= Null;
elsif I.State = Done then
return More(I.Parent);
else
return True;
end if;
end More;
----------------------------------------------------------------------------
procedure pop_Iterator(
I: in out Iterator
)
is
NI: Iterator;
begin
loop
NI := I;
I := I.Parent;
Free_Iterator(NI);
exit when I = Null;
exit when I.State /= Done;
end loop;
end pop_Iterator;
procedure Next( --| Scan the next value in I
I: in out Iterator; --| an active iterator
V: out Value_Type --| Next value scanned
) --| Raises: No_More.
is
NI: Iterator;
begin
if I = Null or I.State = Done then
raise No_More;
end if;
case I.State is
when Left => -- Return the leftmost value
while I.subtree.Less /= Null loop -- Find leftmost subtree
I.State := Middle; -- Middle is next at this level
I := subtree_Iter(I.subtree.Less, I);
end loop;
V := I.subtree.Value;
if I.subtree.More /= Null then -- There will be more...
I.State := Right; -- ... coming from the right
else -- Nothing else here
pop_Iterator(I); -- Pop up to parent iterator
end if;
when Middle =>
V := I.subtree.Value;
if I.subtree.More /= Null then -- There will be more...
I.State := Right; -- ... coming from the right
else -- Nothing else here so...
pop_Iterator(I); -- ... Pop up to parent iterator
end if;
when Right => -- Return the value on the right
I.State := Done; -- No more at this level
I := subtree_Iter(I.subtree.More, I);
Next(I, V);
when Done =>
pop_Iterator(I);
Next(I, V);
end case;
end Next;
----------------------------------------------------------------------------
end binary_trees_pkg;
With Text_io;
package body Bounded_String is
procedure Free (The_String : in out Variable_String) is
begin
The_String.The_Length := void;
end Free;
procedure Append (Target : in out Variable_String;
Source : in character) is
begin
If (Target.The_Length < Target.The_Content'Last) then
Target.The_Length := Target.The_Length +1;
Target.The_Content (Target.The_Length) := Source;
end if;
end Append;
procedure Set (The_String : in out Variable_String;
With_String : in String) is
begin
If (With_String'Last <= The_String.The_Content'Last) then
The_String.The_Length := With_String'length;
The_String.The_Content (With_String'Range) :=
With_String(With_String'Range);
else
The_String.The_Length := The_String.The_Content'Length;
The_String.The_Content (The_String.The_Content'Range) :=
With_String(The_String.The_Content'Range);
end if;
end Set;
procedure Copy (The_String : in out Variable_String;
With_String : in String) is
begin
If (With_String'Last <= The_String.The_Content'Last) then
The_String.The_Length := With_String'length;
The_String.The_Content (With_String'Range) :=
With_String(With_String'Range);
else
The_String.The_Length := The_String.The_Content'Length;
The_String.The_Content (The_String.The_Content'Range) :=
With_String(The_String.The_Content'Range);
end if;
end Copy;
function Image (From_The_String : in Variable_String) return String is
begin
return (From_The_String.The_Content(1..From_The_String.The_Length));
end Image;
end Bounded_String;With Lexical,Token_List,Erreur,Etat;
Use Lexical,Token_List;
Package body Connexions is
Connexion_First:Token_List.Object := Make(Creer_Connexion);
Procedure Connexion is
Begin
if Lexical.Get_Token = Creer_Connexion then
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Virgul then
Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Virgul then
Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Virgul then
Lexical.Next;
Etat.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Mauvais qualificateur");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Mauvais id");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Mauvais id");
end if;
else
Erreur.Parse("Manque (");
end if;
else
Erreur.Parse("Manque CREER_CONNEXION");
end if;
End Connexion;
Procedure Parse is
Begin
Connexion;
while Is_In(Lexical.Get_Token,Connexion_First) loop
Connexion;
end loop;
End Parse;
End Connexions;
With Lexical,Token_List,Erreur,Variable,Nom_de_variable,Etat,Nombre;
Use Lexical,Token_List;
Package body Corps_cond is
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,Variable.First) then
Variable.Parse;
else
if Is_In(Lexical.Get_Token,Etat.First) then
Etat.Parse;
else
if Is_In(Lexical.Get_Token,Nombre.First) then
Nombre.Parse;
else
case Lexical.Get_Token is
when Existe_Connexion | Etat_Connexion |
Existe_Lien | Etat_Lien =>
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Virgul then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Manque (");
end if;
when Vrai | Faux => Lexical.Next;
when others => Erreur.Parse("Mauvaise condition");
end case;
end if;
end if;
end if;
End Parse;
End Corps_cond;
With Lexical,Token_List,Erreur,Definitions_simples,Noms;
Use Lexical,Token_List;
Package body Definitions is
Definition_First:Token_List.Object := Make((Structure,Enumere));
Procedure Definition is
Begin
case Lexical.Get_Token is
when Structure => Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Definitions_simples.Parse;
If Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque (");
end if;
else
Erreur.Parse("Manque Nom de structure");
end if;
when Enumere => Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Noms.Parse;
If Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque (");
end if;
else
Erreur.Parse("Manque Nom de enumere");
end if;
when others => Erreur.Parse("Manque Enumere/Structure");
end case;
End Definition;
Procedure Parse is
Begin
Definition;
while Is_In(Lexical.Get_Token,Definition_First) loop
Definition;
end loop;
End Parse;
End Definitions;
With Lexical,Token_List,Erreur,Nom_de_Type;
Use Lexical,Token_List;
Package body Definitions_simples is
First_bis:Token_List.Object := Make(Virgul);
Procedure Definition_simple is
Begin
Nom_de_Type.Parse;
if Lexical.Get_Token = Id then
Lexical.Next;
else
Erreur.Parse("Manque Id");
end if;
End Definition_simple;
Procedure Parse is
Begin
Definition_simple;
while Is_In(Lexical.Get_Token,First_bis) loop
Lexical.Next;
Definition_simple;
end loop;
End Parse;
End Definitions_simples;
With Lexical,Token_List,Erreur,Qualificateur,Connexions;
Use Lexical,Token_List;
Package body Def_Connexions is
First:Token_List.Object := Qualificateur.First;
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,First) then
Qualificateur.Parse;
Connexions.Parse;
end if;
End Parse;
End Def_Connexions;
With Text_Io,Lexical;
Package body Erreur is
Erreur_Flag:Boolean := False;
Procedure Parse(message:String) is
Begin
Text_Io.Put(message);
Text_Io.Put(" dans la ligne:");
Text_Io.Put(Natural'Image (Lexical.Get_Line));
Text_Io.Put(" dans la colone:");
Text_Io.Put(Natural'Image (Lexical.Get_Column));
Erreur_Flag:=True;
raise Erreur_Syntaxe;
End Parse;
Function Is_Any return Boolean is
Begin
return Erreur_Flag;
End Is_Any;
End Erreur;
With Lexical,Token_List,Erreur;
Use Lexical,Token_List;
Package body Etat is
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,First) then
Lexical.Next;
else
Erreur.Parse("Etat Inconnu");
end if;
End Parse;
End Etat;
With Lexical,Token_List,Erreur,Terme;
Use Lexical,Token_List;
Package body Expression is
First_bis:Token_List.Object := Make((Plus,Moins,Ou));
Procedure Parse is
Begin
Terme.Parse;
while Is_In(Lexical.Get_Token,First_bis) loop
Lexical.Next;
Terme.Parse;
end loop;
End Parse;
End Expression;
With Lexical,Token_List,Erreur,Terme_cond;
Use Lexical,Token_List;
Package body Exp_cond is
First_bis:Token_List.Object := Make(Ou);
Procedure Parse is
Begin
Terme_cond.Parse;
while Is_In(Lexical.Get_Token,First_bis) loop
Lexical.Next;
Terme_cond.Parse;
end loop;
End Parse;
End Exp_cond;
With Lexical,Token_List,Erreur,Expression,Facteur,Nom_de_variable;
Use Lexical,Token_List;
Package body Expression_Generale is
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,Expression.First) then
Expression.Parse;
else
if Lexical.Get_Token = Destination_Connexion then
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Virgul then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Mauvaise expression/fonction lors de l affectation");
end if;
end if;
End Parse;
End Expression_Generale;
With Lexical,Token_List,Erreur,Expression,Variable,Nombre;
Use Lexical,Token_List;
Package body Facteur is
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,Nombre.First) then
Nombre.Parse;
else
case Lexical.Get_Token is
when Parnto => Lexical.Next;
Expression.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
when Non => Lexical.Next;
Parse;
when Id | Comp => Variable.Parse;
when Vrai | Faux => Lexical.Next;
when others => Erreur.Parse("Facteur non valide");
end case;
end if;
End Parse;
End Facteur;
With Lexical,Token_List,Erreur,Exp_cond,Corps_cond,Test,Liste_des_entrees;
Use Lexical,Token_List;
Package body Facteur_cond is
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,Corps_cond.First) then
Corps_cond.Parse;
Test.Parse;
Corps_cond.Parse;
else
case Lexical.Get_Token is
when Parnto => Lexical.Next;
Exp_cond.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
when Crocho => Lexical.Next;
Liste_des_entrees.Parse;
if Lexical.Get_Token = Crochf then
Lexical.Next;
else
Erreur.Parse("Manque ]");
end if;
when others => Erreur.Parse("Condition Incorrecte");
end case;
end if;
End Parse;
End Facteur_cond;
With Lexical,Erreur;
Use Lexical;
Package body Fin_Jeu is
Procedure Parse is
Begin
if Lexical.Get_Token = Fin then
Lexical.Next;
else
Erreur.Parse ("Manque FIN");
end if;
End Parse;
End Fin_Jeu;
With Lexical,Erreur,Init_Complexe,Init_Simple;
Use Lexical;
Package body Initialisation is
Procedure Parse is
Begin
case Lexical.Get_Token is
when Avec => Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Init_Complexe.Parse;
If Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque (");
end if;
when Init => Lexical.Next;
Init_Simple.Parse;
when others => Erreur.Parse("Manque Avec/Init");
end case;
End Parse;
End Initialisation;
With Lexical,Token_List,Erreur,Init_Simple;
Use Lexical,Token_List;
Package body Init_Complexe is
First_bis:Token_List.Object := Make(Virgul);
Procedure Parse is
Begin
Init_Simple.Parse;
while Is_In(Lexical.Get_Token,First_bis) loop
Lexical.Next;
Init_Simple.Parse;
end loop;
End Parse;
End Init_Complexe;
With Lexical,Token_List,Erreur,Nombre;
Use Lexical,Token_List;
Package body Init_Simple is
First:Token_List.Object := Make((Str,Moins,Nbr,Vrai,Faux,Id));
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,First) then
if Is_In(Lexical.Get_Token,Nombre.First) then
Nombre.Parse;
else
Lexical.Next;
end if;
else
Erreur.Parse("Initialisation Inconnue");
end if;
End Parse;
End Init_Simple;
With Lexical,Token_List,Erreur,Instruction_si,Nom_de_variable,Variable,Expression_generale,Etat,Param_afficher;
Use Lexical,Token_List;
Package body Instructions is
Instruction_First:Token_List.Object := Make((Si,Moins,Comp,Detruire_connexion,Lie_Connexion,
Delie_Connexion,Detruire_Lien,Lie_Lien,Delie_Lien,
Liste_Lien,Echanger_Lien,Afficher,Fin));
Procedure Instruction is
Begin
if Is_In(Lexical.Get_Token,Instruction_si.First) then
Instruction_si.Parse;
else
if Is_In(Lexical.Get_Token,Variable.First) then
Variable.Parse;
if Lexical.Get_Token = Affect then
Lexical.Next;
Expression_generale.Parse;
else
Erreur.Parse("Manque :=");
end if;
else
case Lexical.Get_Token is
when Detruire_Connexion | Echanger_Lien =>
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Virgul then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Virgul then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Manque (");
end if;
when Lie_Connexion | Delie_Connexion | Detruire_Lien |
Lie_Lien | Delie_Lien =>
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Virgul then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Manque (");
end if;
when Liste_Lien =>
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Nom_de_variable.Parse;
if Lexical.Get_Token = Virgul then
Lexical.Next;
Etat.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Manque (");
end if;
when Afficher =>
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Param_afficher.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque (");
end if;
when Fin => Lexical.Next;
when others => Erreur.Parse("Mauvaise instruction");
end case;
end if;
end if;
End Instruction;
Procedure Parse is
Begin
Instruction;
while Is_In(Lexical.Get_Token,Instruction_First) loop
Instruction;
end loop;
End Parse;
End Instructions;
With Lexical,Erreur,Instructions;
Use Lexical;
Package body Instruction_pour is
Procedure Parse is
Begin
if Lexical.Get_Token = Pour then
Lexical.Next;
if Lexical.Get_Token = Nbr then
Lexical.Next;
if Lexical.Get_Token = Entree then
Lexical.Next;
if Lexical.Get_Token = Faire then
Lexical.Next;
Instructions.Parse;
if Lexical.Get_Token = Finpour then
Lexical.Next;
else
Erreur.Parse ("Manque Finpour");
end if;
else
Erreur.Parse ("Manque Faire");
end if;
else
Erreur.Parse ("Manque Entree");
end if;
else
Erreur.Parse ("Manque le nombre d actions");
end if;
else
Erreur.Parse ("Manque Pour");
end if;
End Parse;
End Instruction_pour;
With Lexical,Erreur,Exp_cond,Instructions;
Use Lexical;
Package body Instruction_si is
Procedure Bloc_sinon is
Begin
if Lexical.Get_Token = Sinon then
Lexical.Next;
Instructions.Parse;
end if;
End Bloc_sinon;
Procedure Parse is
Begin
if Lexical.Get_Token = Si then
Lexical.Next;
Exp_cond.Parse;
if Lexical.Get_Token = Alors then
Lexical.Next;
Instructions.Parse;
Bloc_sinon;
if Lexical.Get_Token = Finsi then
Lexical.Next;
else
Erreur.Parse ("Manque Finsi");
end if;
else
Erreur.Parse ("Manque Alors");
end if;
else
Erreur.Parse ("Manque Si");
end if;
End Parse;
End Instruction_si;
With Lexical,Token_List,Erreur,Instruction_si,Instruction_pour;
Use Lexical,Token_List;
Package body Instructions_Globales is
Instruction_globale_First:Token_List.Object := Make((Si,Pour));
Procedure Instruction_Globale is
Begin
if Is_In(Lexical.Get_Token,Instruction_si.First) then
Instruction_si.Parse;
else
if Is_In(Lexical.Get_Token,Instruction_pour.First) then
Instruction_pour.Parse;
else
Erreur.Parse("Mauvaise instruction globale");
end if;
end if;
End Instruction_Globale;
Procedure Parse is
Begin
Instruction_Globale;
while Is_In(Lexical.Get_Token,Instruction_globale_First) loop
Instruction_Globale;
end loop;
End Parse;
End Instructions_Globales;
With Lexical,Token_List,Erreur,Instruction_si;
Use Lexical,Token_List;
Package body Instructions_Locales is
Instruction_locale_First:Token_List.Object := Make(Si);
Procedure Instruction_Locale is
Begin
Instruction_si.Parse;
End Instruction_Locale;
Procedure Parse is
Begin
Instruction_Locale;
while Is_In(Lexical.Get_Token,Instruction_locale_First) loop
Instruction_Locale;
end loop;
End Parse;
End Instructions_Locales;
With Lexical,Verbs_Dictionary,Erreur,Actions;
Use Lexical;
Package body Les_Actions is
Procedure Parse (dict:Verbs_Dictionary.Object) is
Begin
If Lexical.Get_Token = Action Then
Lexical.Next;
Actions.Parse(dict);
Else
Erreur.Parse ("Manque ACTION");
End if;
End Parse;
End Les_Actions;
with Bounded_String, Source, Text_Io;
use Bounded_String;
package body Lexical is
type State is (St_Normal, St_Comment, St_Nbr, St_Debstr, St_Finstr,
St_Id, St_2point, St_Affect, St_Inf, St_Infequ,
St_Diffr, St_Sup, St_Supequ, St_Newlinestr, St_Found);
subtype Minuscule is Character range 'a' .. 'z';
subtype Majuscule is Character range 'A' .. 'Z';
subtype Digit is Character range '0' .. '9';
subtype Keyword is Token range Jeu .. Fin;
Currentvalue : Variable_String (Maxstring);
Currenttoken : Token;
function Iskeyword (The_String : in String) return Boolean is
T : Keyword;
begin
T := Keyword'Value (The_String);
return True;
exception
when Constraint_Error =>
return False;
end Iskeyword;
function Keywordtotoken (Word : in String) return Token is
begin
if Iskeyword (Word) then
return Token'Value (Word);
else
return Id;
end if;
end Keywordtotoken;
procedure Get_State_After_Inf
(Astate : in out State; Achar : in Character) is
begin
case Achar is
when '=' =>
Currenttoken := Infequ;
when '>' =>
Currenttoken := Diffr;
when others =>
Source.Unget;
Currenttoken := Inf;
end case;
Astate := St_Found;
end Get_State_After_Inf;
procedure Get_State_After_Sup
(Astate : in out State; Achar : in Character) is
begin
if (Achar = '=') then
Currenttoken := Supequ;
else
Currenttoken := Sup;
Source.Unget;
end if;
Astate := St_Found;
end Get_State_After_Sup;
procedure Get_String_After_Debstr
(Astate : in out State; Achar : in Character) is
begin
if (Achar = '"') then
Astate := St_Finstr;
elsif (Achar = '\') then
Astate := St_Newlinestr;
elsif not (Achar = Ascii.Cr) then
Bounded_String.Append (Currentvalue, Achar);
end if;
end Get_String_After_Debstr;
procedure Get_String_After_Newlinestr
(Astate : in out State; Achar : in Character) is
begin
if (Achar = '\') then
Astate := St_Debstr;
elsif (Achar = ' ' or Achar = Ascii.Cr or Achar = Ascii.Ht) then
Astate := St_Newlinestr;
else
Currenttoken := Unk;
Astate := St_Found;
end if;
end Get_String_After_Newlinestr;
procedure Get_String_After_Finstr
(Astate : in out State; Achar : in Character) is
begin
if (Achar = '"') then
Bounded_String.Append (Currentvalue, Achar);
Astate := St_Debstr;
else
Currenttoken := Str;
Astate := St_Found;
Source.Unget;
end if;
end Get_String_After_Finstr;
procedure Get_State_After_2point
(Astate : in out State; Achar : in Character) is
begin
if (Achar = '=') then
Currenttoken := Affect;
else
Currenttoken := Unk;
end if;
Astate := St_Found;
end Get_State_After_2point;
procedure Get_Id (Astate : in out State; Achar : in Character) is
begin
if (Achar in Minuscule or Achar in Majuscule or
Achar in Digit or Achar = '_') then
Bounded_String.Append (Currentvalue, Achar);
else
Source.Unget;
Astate := St_Found;
Currenttoken := Keywordtotoken
(Bounded_String.Image (Currentvalue));
end if;
end Get_Id;
procedure Get_Nbr (Astate : in out State; Achar : in Character) is
begin
if (Achar in Digit) then
Bounded_String.Append (Currentvalue, Achar);
else
Source.Unget;
Astate := St_Found;
Currenttoken := Nbr;
end if;
end Get_Nbr;
procedure Get_State_After_Normal
(Astate : in out State; Achar : in Character) is
begin
case Achar is
when Ascii.Cr | Ascii.Ht | ' ' =>
Astate := St_Normal;
when '*' =>
Currenttoken := Mul;
Astate := St_Found;
when '/' =>
Currenttoken := Div;
Astate := St_Found;
when '[' =>
Currenttoken := Crocho;
Astate := St_Found;
when ']' =>
Currenttoken := Crochf;
Astate := St_Found;
when '(' =>
Currenttoken := Parnto;
Astate := St_Found;
when ')' =>
Currenttoken := Parntf;
Astate := St_Found;
when ',' =>
Currenttoken := Virgul;
Astate := St_Found;
when '+' =>
Currenttoken := Plus;
Astate := St_Found;
when '-' =>
Currenttoken := Moins;
Astate := St_Found;
when '.' =>
Currenttoken := Point;
Astate := St_Found;
when '=' =>
Currenttoken := Equ;
Astate := St_Found;
when '{' =>
Astate := St_Comment;
when '"' =>
Astate := St_Debstr;
when ':' =>
Astate := St_2point;
when '<' =>
Astate := St_Inf;
when '>' =>
Astate := St_Sup;
when Digit =>
Bounded_String.Append (Currentvalue, Achar);
Astate := St_Nbr;
when Majuscule | Minuscule =>
Bounded_String.Append (Currentvalue, Achar);
Astate := St_Id;
when others =>
Bounded_String.Append (Currentvalue, Achar);
Currenttoken := Unk;
Astate := St_Found;
end case;
end Get_State_After_Normal;
procedure Init (Nomf : String) is
begin
Source.Init(Nomf);
end Init;
function Get_Token return Token is
begin
return Currenttoken;
end Get_Token;
function Get_Value return String is
begin
return Bounded_String.Image (Currentvalue);
end Get_Value;
function At_End return Boolean is
begin
return Source.At_End;
end At_End;
function Get_Line return Natural is
begin
return Source.Get_Line;
end Get_Line;
function Get_Column return Natural is
begin
return Source.Get_Column;
end Get_Column;
procedure Next is
Currentchar : Character;
Currentstate : State;
begin
if not (Source.At_End) then
Bounded_String.Free (Currentvalue);
Currentstate := St_Normal;
Search_Token:
loop
if not (Source.At_End) then
Source.Next;
Currentchar := Source.Value;
else
Currenttoken := Lexend;
exit Search_Token;
end if;
case Currentstate is
when St_Normal =>
Get_State_After_Normal (Currentstate, Currentchar);
when St_Comment =>
if (Currentchar = '}') then
Currentstate := St_Normal;
end if;
when St_Debstr =>
Get_String_After_Debstr (Currentstate, Currentchar);
when St_Newlinestr =>
Get_String_After_Newlinestr
(Currentstate, Currentchar);
when St_Finstr =>
Get_String_After_Finstr (Currentstate, Currentchar);
when St_2point =>
Get_State_After_2point (Currentstate, Currentchar);
when St_Inf =>
Get_State_After_Inf (Currentstate, Currentchar);
when St_Sup =>
Get_State_After_Sup (Currentstate, Currentchar);
when St_Id =>
Get_Id (Currentstate, Currentchar);
when St_Nbr =>
Get_Nbr (Currentstate, Currentchar);
when others =>
Currenttoken := Unk;
Bounded_String.Append (Currentvalue, Currentchar);
Currentstate := St_Found;
end case;
exit when Currentstate = St_Found;
end loop Search_Token;
else
Currenttoken := Lexend;
end if;
end Next;
procedure Close is
begin
Source.Close;
end Close;
end Lexical;
With Lexical,Erreur,Def_Connexions,Liens;
Use Lexical;
Package body Liaisons is
Procedure Parse is
Begin
Def_Connexions.Parse;
Liens.Parse;
End Parse;
End Liaisons;
With Lexical,Token_List,Erreur,Etat;
Use Lexical,Token_List;
Package body Liens is
Lien_First:Token_List.Object := Make(Creer_Lien);
Procedure Lien is
Begin
if Lexical.Get_Token = Creer_Lien then
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Virgul then
Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Virgul then
Lexical.Next;
Etat.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Mauvais id");
end if;
else
Erreur.Parse("Manque ,");
end if;
else
Erreur.Parse("Mauvais id");
end if;
else
Erreur.Parse("Manque (");
end if;
else
Erreur.Parse("Manque CREER_LIEN");
end if;
End Lien;
Procedure Parse is
Begin
while Is_In(Lexical.Get_Token,Lien_First) loop
Lien;
end loop;
End Parse;
End Liens;
With Lexical,Erreur;
Use Lexical;
Package body Liste_des_entrees is
Procedure Parse is
Begin
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
end if;
else
if Lexical.Get_Token = Comp then
Lexical.Next;
end if;
end if;
else
if Lexical.Get_Token = Comp then
Lexical.Next;
else
Erreur.Parse("Mauvaise expression de saisie joueur");
end if;
end if;
End Parse;
End Liste_des_entrees;
With Lexical,Token_List,Verbs_Dictionary,Erreur;
Use Lexical,Token_List;
Package body Liste_Synonymes is
First_bis:Token_List.Object := Make(Virgul);
Procedure Liste_Synonyme (dict:Verbs_Dictionary.Object) is
Begin
if Lexical.Get_Token = Id then
-- if Verbs_Dictionary.Exist(Lexical.Get_Value,dict) then
-- Erreur.Parse("Synonyme deja existant");
-- else
-- Verbs_Dictionary.Add_Synonym(Lexical.Get_Value,dict);
-- end if;
Lexical.Next;
else
Erreur.Parse("Manque Id");
end if;
End Liste_Synonyme;
Procedure Parse (dict:Verbs_Dictionary.Object) is
Begin
Liste_Synonyme (dict);
while Is_In(Lexical.Get_Token,First_bis) loop
Lexical.Next;
Liste_Synonyme (dict);
end loop;
End Parse;
End Liste_Synonymes;
With Lexical,Erreur,Instructions_Locales;
Use Lexical;
Package body Les_Anims_Locales is
Procedure Parse is
Begin
if Lexical.Get_Token = Animation_Locale then
Lexical.Next;
Instructions_Locales.Parse;
else
Erreur.Parse ("Manque ANIMATION_LOCALE");
end if;
End Parse;
End Les_Anims_Locales;
With Lexical,Erreur,Instructions_Globales;
Use Lexical;
Package body Les_Anims_Globales is
Procedure Parse is
Begin
if Lexical.Get_Token = Animation_Globale then
Lexical.Next;
Instructions_Globales.Parse;
else
Erreur.Parse ("Manque ANIMATION_GLOBALE");
end if;
End Parse;
End Les_Anims_Globales;
With Lexical,Erreur,Definitions;
Use Lexical;
Package body Les_Definitions is
Procedure Parse is
Begin
If Lexical.Get_Token = Definition then
Lexical.Next;
Definitions.Parse;
else
Erreur.Parse ("Manque DEFINITION");
end if;
End Parse;
End Les_Definitions;
With Lexical,Erreur,Liaisons;
Use Lexical;
Package body Les_Liaisons is
Procedure Parse is
Begin
if Lexical.Get_Token = Liaison then
Lexical.Next;
Liaisons.Parse;
else
Erreur.Parse ("Manque LIAISON");
end if;
End Parse;
End Les_Liaisons;
With Lexical,Erreur,Presentations;
Use Lexical;
Package body Les_Presentations is
Procedure Parse is
Begin
if Lexical.Get_Token = Presentation then
Lexical.Next;
Presentations.Parse;
else
Erreur.Parse ("Manque PRESENTATION");
end if;
End Parse;
End Les_Presentations;
With Lexical,Erreur;
Use Lexical;
Package body Nombre is
Procedure Parse is
Begin
if Lexical.Get_Token = Moins then
Lexical.Next;
end if;
if Lexical.Get_Token = Nbr then
Lexical.Next;
else
Erreur.Parse("Manque un entier");
end if;
End Parse;
End Nombre;
With Lexical,Token_List,Erreur;
Use Lexical,Token_List;
Package body Noms is
First_bis:Token_List.Object := Make(Virgul);
Procedure Nom is
Begin
if Lexical.Get_Token = Id then
Lexical.Next;
else
Erreur.Parse("Manque Id");
end if;
End Nom;
Procedure Parse is
Begin
Nom;
while Is_In(Lexical.Get_Token,First_bis) loop
Lexical.Next;
Nom;
end loop;
End Parse;
End Noms;
With Lexical,Erreur;
Use Lexical;
Package body Nom_Jeu is
Procedure Parse is
Begin
If Lexical.Get_Token = Jeu Then
Lexical.Next;
If Lexical.Get_Token = Id Then
Lexical.Next;
Else
Erreur.Parse ("Manque un Identificateur");
End if;
Else
Erreur.Parse ("Manque JEU");
End if;
End Parse;
End Nom_Jeu;
With Lexical,Token_List,Erreur;
Use Lexical,Token_List;
Package body Nom_de_Type is
First:Token_List.Object := Make((Chaine,Entier,Booleen,Id));
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,First) then
Lexical.Next;
else
Erreur.Parse("Type Inconnu");
end if;
End Parse;
End Nom_de_Type;
With Lexical,Token_List,Erreur;
Use Lexical,Token_List;
Package body Nom_de_variable is
First:Token_List.Object := Make((Id,Comp));
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,First) then
Lexical.Next;
else
Erreur.Parse("Nom de variable Inconnu");
end if;
End Parse;
End Nom_de_variable;
With Lexical,Token_List,Erreur,Variable;
Use Lexical,Token_List;
Package body Param_afficher is
First_bis:Token_List.Object := Make(Virgul);
Procedure Param is
Begin
case Lexical.Get_Token is
when Str => Lexical.Next;
when Id | Comp => Variable.Parse;
when Others => Erreur.Parse("Mauvais parametre afficher");
end case;
End Param;
Procedure Parse is
Begin
Param;
while Is_In(Lexical.Get_Token,First_bis) loop
Lexical.Next;
Param;
end loop;
End Parse;
End Param_afficher;
With Lexical,Token_List,Erreur,Nom_De_Type,Initialisation;
Use Lexical,Token_List;
Package body Presentations is
Presentation_First:Token_List.Object := Make(Id);
Procedure Presentation is
Begin
if Lexical.Get_Token = Id then
Lexical.Next;
if Lexical.Get_Token = Objet then
Lexical.Next;
Nom_De_Type.Parse;
Initialisation.Parse;
else
Erreur.Parse("Manque Objet");
end if;
else
Erreur.Parse("Manque Nom Objet");
end if;
End Presentation;
Procedure Parse is
Begin
Presentation;
while Is_In(Lexical.Get_Token,Presentation_First) loop
Presentation;
end loop;
End Parse;
End Presentations;
With Lexical,Erreur,Noms;
Use Lexical;
Package body Qualificateur is
Procedure Parse is
Begin
if Lexical.Get_Token = Connexion then
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Noms.Parse;
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque (");
end if;
else
Erreur.Parse("Manque CONNEXION");
end if;
End Parse;
End Qualificateur;
package body Source is
Currentchar : Character;
Lookahead : Boolean;
Currentline : Natural;
Currentcol : Natural;
Handle : T_File;
procedure Init ( Nomf : String ) is
begin
Lookahead := False;
Currentline := 1;
Currentcol := 0;
Text_Io.Open (File => Handle, Mode => Text_Io.In_File, Name => Nomf);
end Init;
function Get_Line return Natural is
begin
return Currentline;
end Get_Line;
function Get_Column return Natural is
begin
return Currentcol;
end Get_Column;
function Value return Character is
begin
return Currentchar;
end Value;
procedure Unget is
begin
Lookahead := True;
end Unget;
function At_End return Boolean is
begin
return (Text_Io.End_Of_File (Handle));
end At_End;
procedure Next is
begin
if (Lookahead = False) then
if Text_Io.End_Of_File (Handle) then
Currentchar := Eof;
elsif Text_Io.End_Of_Line (Handle) then
Text_Io.Skip_Line (Handle);
Currentchar := Ascii.Cr;
Currentline := Currentline + 1;
Currentcol := 0;
else
Text_Io.Get (Handle, Currentchar);
Currentcol := Currentcol + 1;
end if;
else
Lookahead := False;
end if;
end Next;
function Get return Character is
begin
Next;
return (Value);
end Get;
procedure Close is
begin
Text_Io.Close( Handle );
end Close;
end Source;
With Lexical,Verbs_Dictionary,Erreur,Liste_Synonymes;
Use Lexical;
Package body Synonymes is
Procedure Parse (dict:Verbs_Dictionary.Object) is
Begin
if Lexical.Get_Token = Synonyme then
Lexical.Next;
if Lexical.Get_Token = Parnto then
Lexical.Next;
Liste_Synonymes.Parse (dict);
if Lexical.Get_Token = Parntf then
Lexical.Next;
else
Erreur.Parse("Manque )");
end if;
else
Erreur.Parse("Manque (");
end if;
end if;
End Parse;
End Synonymes;
With Lexical,Token_List,Erreur,Facteur;
Use Lexical,Token_List;
Package body Terme is
First_bis:Token_List.Object := Make((Mul,Div,Ou));
Procedure Parse is
Begin
Facteur.Parse;
while Is_In(Lexical.Get_Token,First_bis) loop
Lexical.Next;
Facteur.Parse;
end loop;
End Parse;
End Terme;
With Lexical,Token_List,Erreur,Facteur_cond;
Use Lexical,Token_List;
Package body Terme_cond is
First_bis:Token_List.Object := Make(Et);
Procedure Parse is
Begin
Facteur_cond.Parse;
while Is_In(Lexical.Get_Token,First_bis) loop
Lexical.Next;
Facteur_cond.Parse;
end loop;
End Parse;
End Terme_cond;
With Lexical,Token_List,Erreur;
Use Lexical,Token_List;
Package body Test is
First:Token_List.Object := Make((Equ,Inf,Sup,Infequ,Supequ,Diffr));
Procedure Parse is
Begin
if Is_In(Lexical.Get_Token,First) then
Lexical.Next;
else
Erreur.Parse("Operateur de test inconnu");
end if;
End Parse;
End Test;
With Lexical;
Use Lexical;
Package body Token_List is
Function Make (list:Tokens) return Object is
local_object:Object := ( others => False );
begin
for cpt in list'range loop
local_object(list(cpt)) := True;
end loop;
return local_object;
end Make;
Function Make (one_token:Token) return Object is
local_object:Object := ( others => False );
begin
local_object(one_token):=True;
return local_object;
end Make;
Function Is_In (one_token:Token; what:Object) return Boolean is
begin
return what(one_token);
end Is_In;
End Token_List;With Lexical,Erreur,Nom_de_variable;
Use Lexical;
Package body Variable is
Procedure Parse is
Begin
Nom_de_variable.Parse;
if Lexical.Get_Token = Point then
Lexical.Next;
if Lexical.Get_Token = Id then
Lexical.Next;
else
Erreur.Parse("Membre incorrect");
end if;
end if;
End Parse;
End Variable;
With Binary_Trees_Pkg,Bounded_String,Text_Io;
Use Bounded_String;
Package body Verbs_Dictionary is
Lower: Constant Integer := -1;
Equal: Constant Integer := 0;
Upper: Constant Integer := 1;
Current_Verb: Verb;
-- ----------------------------------------------------
-- Definition des fonctions pour le paquetage generique
-- ----------------------------------------------------
Function Compare (a,b:Verb) return Integer is
begin
if Image(a.Name)<Image(b.Name) then
return Lower;
else
if Image(a.Name)=Image(b.Name) then
return Equal;
else
return Upper;
end if;
end if;
end Compare;
Procedure Write (scr:Verb) is
begin
Text_Io.Put_Line ("Name -> "&Image(scr.Name) &
" / Source ->"&Image(scr.Source));
end Write;
Procedure Show is new Verbs_Tree.Visit (Write);
-- -------------------------------------------
-- Definition des fontions de Verbs_Dictionary
-- -------------------------------------------
Function Affect_Verb (name,source:String) return Verb is
tmp_verb:Verb;
begin
Bounded_String.Free(tmp_verb.Name);
Bounded_String.Free(tmp_verb.Source);
Bounded_String.Copy(tmp_verb.Name,name);
Bounded_String.Copy(tmp_verb.Source,source);
return tmp_verb;
end Affect_Verb;
Procedure Create (dict: in out Object) is
begin
dict.Root:=Verbs_Tree.Create;
end Create;
Procedure Destroy (dict: in out Object) is
begin
Verbs_Tree.Destroy (dict.Root);
end Destroy;
Procedure Add_New (new_verb:String; dict:Object) is
begin
Current_Verb:=Affect_Verb(new_verb,new_verb);
Verbs_Tree.Insert(Affect_Verb(new_verb,new_verb),dict.Root);
Exception
when Verbs_Tree.Duplicate_Value => raise Duplicate_Value;
end Add_New;
Procedure Add_Synonym (new_syn:String; dict:Object) is
begin
Verbs_Tree.Insert(Affect_Verb(new_syn,Image(Current_Verb.Source)),dict.Root);
Exception
when Verbs_Tree.Duplicate_Value => raise Duplicate_Value;
end Add_Synonym;
Function Exist (scan_verb:String; dict:Object) return Boolean is
begin
return Verbs_Tree.Is_Found(Affect_Verb(scan_verb,scan_verb),dict.Root);
end Exist;
Procedure Dump (dict:Object) is
begin
Show(dict.Root,Verbs_Tree.InOrder);
end Dump;
end Verbs_Dictionary;
With Verbs_Dictionary;
Package Actions is
Procedure Parse (dict:Verbs_Dictionary.Object);
End Actions;
generic
type Value_Type is private; --| Type of values stored in the tree.
with function Difference(P, Q: Value_Type) return integer is <>;
--| Must return a value > 0 if P > Q, 0 if P = Q, and less than
--| zero otherwise.
package binary_trees_pkg is --| Efficient implementation of binary trees.
--| OVERVIEW
--| This package is an efficient implementation of unbalanced binary trees.
--| These trees have the following properties:
--|-
--| 1. Inserting a value is cheap (log n Differences per insertion).
--| 2. Finding a value is cheap (log n Differences per querey).
--| 3. Can iterate over the values in sorted order in linear time.
--| 4. Space overhead is moderate (2 "pointers" per value stored).
--|+
--| They are thus useful both for sorting sequences of indeterminate size
--| and for lookup tables.
--|
--| OPERATIONS
--|
--|-The following operations are provided:
--|
--| Insert Insert a node into a tree
--| Insert_if_not_Found Insert a node into a tree if not there already
--| Replace_if_Found Replace a node if duplicate exists, else insert.
--| Destroy Destroy a tree
--| Destroy_Deep* Destroy a tree and its contents
--| Balanced_Tree* Create a balanced tree from values supplied in order
--| Copy* Copy a tree. The copy is balanced.
--|
--| Queries:
--| Is_Empty Return TRUE iff a tree is empty.
--| Find Search tree for a node
--| Is_Found Return TRUE iff tree contains specified value.
--| Size Return number of nodes in the tree.
--|
--| Iterators:
--| Visit* Apply a procedure to every node in specified order
--| Make_Iter Create an iterator for ordered scan
--| More Test for exhausted iterator
--| Next Bump an iterator to the next element
--|
--| * Indicates generic subprogram
--|
--| USAGE
--|
--| The following example shows how to use this package where nodes in
--| the tree are labeled with a String_Type value (for which a natural
--| Difference function is not available).
--|-
--| package SP renames String_Pkg;
--|
--| type my_Value is record
--| label: SP.string_type;
--| value: integer;
--| end record;
--|
--| function differ_label(P, Q: SP.string_type) return integer is
--| begin
--| if SP."<"(P, Q) then return -1;
--| elsif SP."<"(Q, P) then return 1;
--| else return 0;
--| end if;
--| end differ_label;
--|
--| package my_Tree is new Binary_Trees_pkg(my_Value, differ_Label);
--|
--| Note that the required Difference function may be easily written in terms
--| of "<" if that is available, but that frequently two comparisons must
--| be done for each Difference. However, both comparisons would have
--| to be done internally by this package for every instantiation if the
--| generic parameter were "<" instead of Difference.
--|
--| PERFORMANCE
--|
--| Every node can be visited in the tree in linear time. The cost
--| of creating an iterator is small and independent of the size
--| of the tree.
--|
--| Recognizing that comparing values can be expensive, this package
--| takes a Difference function as a generic parameter. If it took
--| a comparison function such as "<", then two comparisons would be
--| made per node visited during a search of the tree. Of course this
--| is more costly when "<" is a trivial operation, but in those cases,
--| Difference can be bound to "-" and the overhead in negligable.
--|
--| Two different kinds of iterators are provided. The first is the
--| commonly used set of functions Make_Iter, More, and Next. The second
--| is a generic procedure called Visit. The generic parameter to Visit is
--| a procedure which is called once for each value in the tree. Visit
--| is more difficult to use and results in code that is not quite as clear,
--| but its overhead is about 20% of the More/Next style iterator. It
--| is therefore recommended for use only in time critical inner loops.
----------------------------------------------------------------------------
-- Exceptions --
----------------------------------------------------------------------------
Duplicate_Value: exception;
--| Raised on attempt to insert a duplicate node into a tree.
Not_Found: exception;
--| Raised on attempt to find a node that is not in a tree.
No_More: exception;
--| Raised on attempt to bump an iterator that has already scanned the
--| entire tree.
Out_Of_Order: exception;
--| Raised if a problem in the ordering of a tree is detected.
Invalid_Tree: exception;
--| Value is not a tree or was not properly initialized.
----------------------------------------------------------------------------
-- Types --
----------------------------------------------------------------------------
type Scan_Kind is (inorder, preorder, postorder);
--| Used to specify the order in which values should be scanned from a tree:
--|-
--| inorder: Left, Node, Right (nodes visited in increasing order)
--| preorder: Node, Left, Right (top down)
--| postorder: Left, Right, Node (bottom up)
type Tree is private;
type Iterator is private;
----------------------------------------------------------------------------
-- Operations --
----------------------------------------------------------------------------
Function Create --| Return an empty tree.
return Tree;
--| Effects: Create and return an empty tree. Note that this allocates
--| a small amount of storage which can only be reclaimed through
--| a call to Destroy.
----------------------------------------------------------------------------
Procedure Insert( --| Insert a value into a tree.
V: Value_Type; --| Value to be inserted
T: Tree --| Tree to contain the new value
);
--| Raises: Duplicate_Value, Invalid_Tree.
--| Effects: Insert V into T in the proper place. If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, the exception Duplicate_Value is raised.
--| Caution: Since this package does not attempt to balance trees as
--| values are inserted, it is important to remember that inserting
--| values in sorted order will create a degenerate tree, where search
--| and insertion is proportional to the N instead of to Log N. If
--| this pattern is common, use the Balanced_Tree function below.
----------------------------------------------------------------------------
procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean; --| Becomes True iff V already in tree
Duplicate: out Value_Type --| the duplicate value, if there is one
); --| Raises: Invalid_Tree.
--| Effects: Insert V into T in the proper place. If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, Found will be True and Duplicate will be the duplicate
--| value. This might be a sequence of values with the same key, and
--| V can then be added to the sequence.
----------------------------------------------------------------------------
procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean; --| Becomes True iff L already in tree
Old_Value: out Value_Type --| the duplicate value, if there is one
); --| Raises: Invalid_Tree.
--| Effects: Search for V in T. If found, replace the old value with V,
--| and return Found => True, Old_Value => the old value. Otherwise,
--| simply insert V into T and return Found => False.
----------------------------------------------------------------------------
procedure Destroy( --| Free space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
);
--| Effects: The space allocated to T is reclaimed. The space occupied by
--| the values stored in T is not however, recovered.
----------------------------------------------------------------------------
generic
with procedure free_Value(V: in out Value_Type) is <>;
procedure Destroy_Deep( --| Free all space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
);
--| Effects: The space allocated to T is reclaimed. The values stored
--| in T are reclaimed using Free_Value, and the tree nodes themselves
--| are then reclaimed (in a single walk of the tree).
----------------------------------------------------------------------------
generic
with function next_Value return Value_Type is <>;
--| Each call to this procedure should return the next value to be
--| inserted into the balanced tree being created. If necessary,
--| this function should check that each value is greater than the
--| previous one, and raise Out_of_Order if necessary. If values
--| are not returned in strictly increasing order, the results are
--| unpredictable.
Function Balanced_Tree(
Count: natural
) return Tree;
--| Effects: Create a balanced tree by calling next_Value Count times.
--| Each time Next_Value is called, it must return a value that compares
--| greater than the preceeding value. This function is useful for balancing
--| an existing tree (next_Value iterates over the unbalanced tree) or
--| for creating a balanced tree when reading data from a file which is
--| already sorted.
----------------------------------------------------------------------------
generic
with function Copy_Value(V: Value_Type) return Value_Type is <>;
--| This function is called to copy a value from the old tree to the
--| new tree.
Function Copy_Tree(
T: Tree
) return Tree; --| Raises Invalid_Tree.
--| Effects: Create a balanced tree that is a copy of the tree T.
--| The exception Invalid_Tree is raised if T is not a valid tree.
----------------------------------------------------------------------------
Function Is_Empty( --| Check for an empty tree.
T: Tree
) return boolean;
--| Effects: Return TRUE iff T is an empty tree or if T was not initialized.
----------------------------------------------------------------------------
Function Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Value_Type; --| Raises: Not_Found, Invalid_Tree.
--| Effects: Search T for a value that matches V. The matching value is
--| returned. If no matching value is found, the exception Not_Found
--| is raised.
Procedure Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree; --| Tree to be searched
Found: out Boolean; --| TRUE iff a match was found
Match: out Value_Type --| Matching value found in the tree
); --| Raises: Invalid_Tree;
--| Effects: Search T for a value that matches V. On return, if Found is
--| TRUE then the matching value is returned in Match. Otherwise, Found
--| is FALSE and Match is undefined.
----------------------------------------------------------------------------
function is_Found( --| Check a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Boolean; --| Raises: Invalid_Tree;
--| Effects: Return TRUE iff V is found in T.
----------------------------------------------------------------------------
function Size( --| Return the count of values in T.
T: Tree --| a tree
) return natural;
--| Effects: Return the number of values stored in T.
----------------------------------------------------------------------------
generic
with procedure Process(V: Value_Type) is <>;
procedure Visit(
T: Tree;
Order: Scan_Kind
); --| Raises: Invalid_Tree;
--| Effects: Invoke Process(V) for each value V in T. The nodes are visited
--| in the order specified by Order. Although more limited than using
--| an iterator, this function is also much faster.
----------------------------------------------------------------------------
function Make_Iter( --| Create an iterator over a tree
T: Tree
) return Iterator; --| Raises: Invalid_Tree;
----------------------------------------------------------------------------
function More( --| Test for exhausted iterator
I: Iterator --| The iterator to be tested
) return boolean;
--| Effects: Return TRUE iff unscanned nodes remain in the tree being
--| scanned by I.
----------------------------------------------------------------------------
procedure Next( --| Scan the next value in I
I: in out Iterator; --| an active iterator
V: out Value_Type --| Next value scanned
); --| Raises: No_More.
--| Effects: Return the next value in the tree being scanned by I.
--| The exception No_More is raised if there are no more values to scan.
----------------------------------------------------------------------------
private
type Node;
type Node_Ptr is access Node;
type Node is
record
Value: Value_Type;
Less: Node_Ptr;
More: Node_Ptr;
end record;
type Tree_Header is
record
Count: natural := 0;
Root: Node_Ptr := Null;
end record;
type Tree is access Tree_Header;
type Iter_State is (Left, Middle, Right, Done);
type Iterator_Record;
type Iterator is access Iterator_Record;
type Iterator_Record is
record
State: Iter_State;
Parent: Iterator;
subtree: Node_Ptr;
end record;
end binary_trees_pkg;
package Bounded_String is
type Variable_String (Length : positive) is private;
procedure Free (The_String : in out Variable_String);
procedure Append (Target : in out Variable_String;
Source : in character);
procedure Set (The_String : in out Variable_String;
With_String : in String);
procedure Copy (The_String : in out Variable_String;
With_String : in String);
function Image (From_The_String : in Variable_String) return String;
Private
void : constant natural := 0;
Type Variable_String (Length : positive) is record
The_Length : natural := void;
The_Content : string (1..Length);
end record;
end Bounded_String;
Package Connexions is
Procedure Parse;
End Connexions;
With Lexical,Token_List;
Use Lexical,Token_List;
Package Corps_cond is
First:Token_List.Object := Make((Id,Comp,Existe_Connexion,Etat_Connexion,
Existe_Lien,Etat_Lien,Moins,Nbr,Vrai,
Faux,Lie,Delie));
Procedure Parse;
End Corps_cond;
Package Definitions is
Procedure Parse;
End Definitions;
Package Definitions_simples is
Procedure Parse;
End Definitions_simples;
Package Def_Connexions is
Procedure Parse;
End Def_Connexions;
Package Erreur is
Erreur_Syntaxe:Exception;
Procedure Parse(message:String);
Function Is_Any return Boolean;
End Erreur;
With Lexical,Token_List;
Use Lexical,Token_List;
Package Etat is
First:Token_List.Object := Make((Lie,Delie));
Procedure Parse;
End Etat;
With Lexical,Token_List;
Use Lexical,Token_List;
Package Expression is
First:Token_List.Object := Make((Parnto,Non,Moins,Nbr,Id,Comp,Vrai,Faux));
Procedure Parse;
End Expression;
Package Exp_cond is
Procedure Parse;
End Exp_cond;
Package Expression_Generale is
Procedure Parse;
End Expression_generale;
Package Facteur is
Procedure Parse;
End Facteur;
Package Facteur_cond is
Procedure Parse;
End Facteur_cond;
Package Fin_Jeu is
Procedure Parse;
End Fin_Jeu;Package Initialisation is
Procedure Parse;
End Initialisation;
Package Init_Complexe is
Procedure Parse;
End Init_Complexe;
Package Init_Simple is
Procedure Parse;
End Init_Simple;
Package Instructions is
Procedure Parse;
End Instructions;
With Lexical,Token_List;
Use Lexical,Token_List;
Package Instruction_pour is
First:Token_List.Object := Make(Pour);
Procedure Parse;
End Instruction_pour;
With Lexical,Token_List;
Use Lexical,Token_List;
Package Instruction_si is
First:Token_List.Object := Make(Si);
Procedure Parse;
End Instruction_si;
Package Instructions_Globales is
Procedure Parse;
End Instructions_Globales;
Package Instructions_Locales is
Procedure Parse;
End Instructions_Locales;
With Verbs_Dictionary;
Package Les_Actions is
Procedure Parse (dict:Verbs_Dictionary.Object);
End Les_Actions;
with Text_Io, Source;
package Lexical is
type Token is (Comment, Nbr, Str, Id, Affect, Equ, Mul, Div, Crocho, Crochf,
Parnto, Parntf, Virgul, Inf, Infequ, Diffr, Sup, Supequ,
Plus, Moins, Point, Unk, Lexend, Jeu, Action, Synonyme,
Definition, Structure, Chaine, Booleen,
Entier, Enumere, Presentation,
Objet, Avec, Init, Creer_Lien, Echanger_Lien, Etat_Lien,
Liste_Lien, Existe_Lien, Detruire_Lien, Lie_Lien, Delie_Lien,
Liaison, Lie, Delie, Vrai, Faux,
Connexion,
Creer_Connexion, Existe_Connexion,
Etat_Connexion, Detruire_Connexion, Destination_Connexion,
Lie_Connexion, Delie_Connexion, Afficher, Pour,
Entree, Faire, Finpour, Si, Alors, Sinon, Finsi, Comp,
Non, Ou, Et, Animation_Globale, Animation_Locale, Fin);
subtype T_File is Text_Io.File_Type;
Maxstring : constant Integer := 80;
procedure Init (Nomf : String);
function Get_Token return Token;
function Get_Value return String;
function At_End return Boolean;
procedure Next;
function Get_Line return Natural;
function Get_Column return Natural;
procedure Close;
end Lexical;
Package Liaisons is
Procedure Parse;
End Liaisons;
Package Liens is
Procedure Parse;
End Liens;
Package Liste_des_entrees is
Procedure Parse;
End Liste_des_entrees;
With Verbs_Dictionary;
Package Liste_Synonymes is
Procedure Parse (dict:Verbs_Dictionary.Object);
End Liste_Synonymes;
Package Les_Anims_Locales is
Procedure Parse;
End Les_Anims_Locales;
Package Les_Anims_Globales is
Procedure Parse;
End Les_Anims_Globales;
Package Les_Definitions is
Procedure Parse;
End Les_Definitions;
Package Les_Liaisons is
Procedure Parse;
End Les_Liaisons;
Package Les_Presentations is
Procedure Parse;
End Les_Presentations;
With Lexical,Token_List;
Use Lexical,Token_List;
Package Nombre is
First:Token_List.Object := Make((Moins,Nbr));
Procedure Parse;
End Nombre;
Package Noms is
Procedure Parse;
End Noms;
Package Nom_Jeu is
Procedure Parse;
End Nom_Jeu;
Package Nom_De_Type is
Procedure Parse;
End Nom_De_Type;
Package Nom_de_variable is
Procedure Parse;
End Nom_de_variable;
Package Param_afficher is
Procedure Parse;
End Param_afficher;
Package Presentations is
Procedure Parse;
End Presentations;
With Lexical,Token_List;
Use Lexical,Token_List;
Package Qualificateur is
First:Token_List.Object := Make(Connexion);
Procedure Parse;
End Qualificateur;
with Text_Io;
package Source is
subtype T_File is Text_Io.File_Type;
Eof : constant Character := Ascii.Eot;
procedure Init (Nomf : String);
function Value return Character;
procedure Unget;
function At_End return Boolean;
procedure Next;
function Get return Character;
function Get_Line return Natural;
function Get_Column return Natural;
procedure Close;
end Source;
With Verbs_Dictionary;
Package Synonymes is
Procedure Parse (dict:Verbs_Dictionary.Object);
End Synonymes;
Package Terme is
Procedure Parse;
End Terme;
Package Terme_cond is
Procedure Parse;
End Terme_cond;
Package Test is
Procedure Parse;
End Test;
With Lexical;
Use Lexical;
Package Token_List is
type Object is private;
type Tokens is array (positive range <>) of Token;
Function Make (list:Tokens) return Object;
Function Make (one_token:Token) return Object;
Function Is_In (one_token:Token; what:Object) return Boolean;
Private
type Object is array(Token) of Boolean;
End Token_List;With Lexical,Token_List;
Use Lexical,Token_List;
Package Variable is
First:Token_List.Object := Make((Id,Comp));
Procedure Parse;
End Variable;
With Binary_Trees_Pkg,Bounded_String;
Use Bounded_String;
Package Verbs_Dictionary is
Duplicate_Value:Exception;
type Object is private;
Procedure Create (dict: in out Object);
Procedure Destroy (dict: in out Object);
Procedure Add_New (new_verb: String; dict: Object);
Procedure Add_Synonym (new_syn: String; dict: Object);
Function Exist (scan_verb: String; dict: Object) return Boolean;
Procedure Dump (dict: Object);
Private
type Verb is record
Name:Variable_String(32);
Source:Variable_String(32);
end record;
Function Compare (a,b:Verb) return Integer;
Package Verbs_Tree is new Binary_Trees_Pkg (Verb,Compare);
type Object is record
Root:Verbs_Tree.Tree;
end record;
end Verbs_Dictionary