|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ A T ┃
Length: 145524 (0x23874)
Types: TextFile
Names: »ALLPROJ«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
WITH Etape,Text_IO;\r
Package Role is\r
SubType Adresse_Peripherique is Natural;\r
Adresse_Vide:Constant Adresse_Peripherique:=9999;\r
\r
SUBTYPE Delai is INTEGER;\r
\r
TYPE acteur is record\r
Peripherique:Adresse_Peripherique;\r
Numero_Fonction:Natural;\r
end record;\r
\r
TYPE DescripteurDeRole is RECORD\r
Lacteur:Acteur;\r
LesEtapes:Etape.Etape;\r
EnCours:BOOLEAN;\r
LeDebut:Etape.Temps;\r
Lindex:Etape.Etape;\r
LaDuree:Etape.Temps;\r
END RECORD;\r
TYPE Role is access DescripteurDeRole;\r
Role_Vide:Constant Role:=null;\r
\r
-- creation\r
FUNCTION CreerUnRole(A:Acteur) return Role;\r
FUNCTION ChargerUnRole(F:IN Text_IO.File_Type) return Role;\r
FUNCTION ChargerUnTemps(F:IN Text_IO.File_Type) return Etape.Temps;\r
FUNCTION ChargerUnActeur(F:IN Text_IO.File_Type) return Acteur;\r
FUNCTION ChargerUneAction(F:IN Text_IO.File_Type) return Etape.Action;\r
-- acces\r
FUNCTION LeRoleEstVide(UnRole:Role) return BOOLEAN;\r
FUNCTION LacteurDuRole(UnRole:Role) return Acteur;\r
FUNCTION LaDureeDuRole(UnRole:Role) return Etape.Temps;\r
FUNCTION LeRoleEstEnCours(UnRole:Role) return BOOLEAN;\r
FUNCTION LeDebutDuRole(UnRole:Role) return Etape.Temps;\r
FUNCTION LesEtapesDuRole(UnRole:Role) return Etape.Etape;\r
PROCEDURE QuelleActionDuRole(UnRole:Role;UnTemps:Etape.Temps;UneAction: out Etape.Action;Existe: out BOOLEAN);\r
FUNCTION LeNombreDactionsDuRole(UnRole:Role) return INTEGER;\r
-- modification\r
PROCEDURE CaserUneActionDansLeRole(UnRole:in out Role;UnTemps:Etape.Temps;UneAction:Etape.Action);\r
PROCEDURE ExclureUneActionDuRole(UnRole:in out Role;UnTemps:Etape.Temps);\r
PROCEDURE DecalerUneActionDuRole(UnRole:in out Role;UnTemps:Etape.Temps;Undelai:Delai);\r
PROCEDURE DeplacerUneActionDuRole(UnRole:in out Role;Ancien:Etape.Temps;Nouveau:Etape.Temps);\r
PROCEDURE DecalerLeRole(UnRole:in out Role;UnDelai:Delai);\r
PROCEDURE ViderLeRole(UnRole:IN OUT Role);\r
-- execution\r
PROCEDURE DemarrerLeRole(UnRole:IN OUT Role);\r
PROCEDURE ArreterLeRole(UnRole:IN OUT Role);\r
PROCEDURE SolliciterLeRole(UnRole:in out Role;TempsCourant:integer);\r
-- sauvegarde\r
PROCEDURE SauvegarderLeRole(UnRole:Role;Fichier:STRING);\r
-- affichage\r
Procedure AfficherUnRole(R:Role);\r
END Role;\r
Package Etape is -- specifications\r
SUBTYPE Temps is INTEGER;\r
TYPE Action is record\r
valeur1: INTEGER;\r
valeur2: INTEGER;\r
end record;\r
TYPE CelluleEtape;\r
TYPE Etape is access CelluleEtape;\r
TYPE CelluleEtape is RECORD\r
LeTemps:Temps;\r
Laction:Action;\r
LaSuite:Etape;\r
END RECORD;\r
EtapeInexistante: constant Etape:=null;\r
FUNCTION CreerUneEtape(UnTemps:temps;UneAction:Action;UneEtape:Etape) return Etape;\r
FUNCTION LeTempsDeLetape(UneEtape:Etape) return Temps;\r
FUNCTION LactionDeLetape(UneEtape:Etape) return Action;\r
FUNCTION LaSuiteDeLetape(UneEtape:Etape) return Etape;\r
PROCEDURE ChangerLeTempsDeLetape(UneEtape: IN OUT Etape;UnTemps:temps);\r
PROCEDURE ChangerLactionDeLetape(UneEtape:IN OUT Etape;UneAction:Action);\r
PROCEDURE CaserUneActionDansLesEtapes(T:temps;A:Action;E:IN OUT Etape);\r
PROCEDURE DetruireLEtape(E:IN OUT Etape);\r
PROCEDURE ExclureUneActionDesEtapes(E:IN OUT Etape;T:temps);\r
\r
PROCEDURE AfficherUneEtape(E:Etape);\r
End Etape;\r
With Etape,Role,Text_IO;\r
package Scene is\r
Type Scene is private;\r
\r
Type Scripte is private;\r
\r
Type Operation is record\r
temps:Etape.temps;\r
Acteur:Role.Acteur;\r
Action:Etape.action;\r
end record;\r
\r
Procedure CreerUneScene(UneScene:in out Scene);\r
Procedure DetruireUneScene(UneScene:in out Scene);\r
\r
Function ChargerUneScene(F:Text_IO.File_Type) return Scene;\r
\r
Procedure JouerUneScene(UneScene:in out Scene);\r
\r
Procedure AfficherUneScene(UneScene:in Scene);\r
\r
Private\r
NbRoles: Constant:=20; -- nbre max de fonctions sur un peripherique\r
NbScriptes:Constant:=50; -- nbre max de peripheriques\r
Type tContenuScripte is array (1..NbRoles) of Role.Role;\r
Type Scripte is record\r
Nom:Role.Adresse_Peripherique;\r
Contenu:tContenuScripte;\r
end record;\r
type tContenuScene is array (1..NbScriptes) of Scripte;\r
TYPE DescripteurDeScene is record\r
NbreScriptes:Natural;\r
Contenu:tContenuScene;\r
end record;\r
Type Scene is access DescripteurDeScene;\r
end Scene;\r
package Formate is\r
Function IntToStr(UnNombre:Natural;NbChiffres:Positive) return string;\r
end formate;\r
With Lexical;\r
package Nodes is\r
type NodeList is (Activer,Desactiver,Modifier,Evoluer,\r
ExpressionPrime,TermePrime,Expression,Terme,Facteur,\r
Id,Nombre,Affect,Faire,Repeter,Si,Sinon,Autemps,\r
Attendre,Condition,NONE);\r
type operator is (add,sub,mul,div,modulo,NONE);\r
type op_rel is (inf,sup,eq,inf_eq,sup_eq,diff,NONE);\r
\r
type Node(aNodeType:NodeList);\r
type pNode is access Node;\r
type Node(aNodeType:NodeList) is\r
record\r
TheType:NodeList:=NONE;\r
Next:pNode:=null;\r
case aNodeType is\r
when Activer => Act_id1,Act_id2:pNode;\r
when Desactiver => Des_id1,Des_id2:pNode;\r
when Modifier => Mod_id1,Mod_id2,Mod_Expr:pNode;\r
when Evoluer => Evo_id1,Evo_id2,Evo_Expr1,Evo_Expr2:pNode;\r
when ExpressionPrime => ExpP_ExprPrime,ExpP_Term:pNode;\r
ExpP_op:operator;\r
when TermePrime => TerP_TermPrime,TerP_Fact:pNode;\r
TerP_op:operator;\r
when Expression => Exp_ExprPrime,Exp_Term:pNode;\r
when Terme => Ter_TermPrime,Ter_Fact:pNode;\r
when Facteur => Fac_Node:pNode;\r
when Id => id_Val:Lexical.Lexeme; -- niveau le plus bas\r
when nombre => Nb_Val:Integer;\r
when Affect => Aff_id,Aff_Expr:pNode;\r
when Faire => Fai_id1,fai_id2:pNode;\r
when Repeter => Rep_Expr,Rep_Instr:pNode;\r
when si => Si_Cond,Si_Instr,Si_Sinon:pNode;\r
when sinon => Sin_Instr:pNode;\r
when Autemps => Aut_Expr,Aut_Instr:pNode;\r
when Attendre => Att_Expr:pNode;\r
when Condition => Con_Expr1,Con_Expr2:pNode;\r
Con_op:op_rel;\r
Con_Val:Boolean:=True;\r
when NONE => null;\r
end case;\r
end record;\r
\r
function MkActiverNode(id1,id2:pNode) return pNode;\r
function MkDesactiverNode(id1,id2:pNode) return pNode;\r
function MkModifierNode(id1,id2,Expr:pNode) return pNode;\r
function MkEvoluerNode(id1,id2,Expr1,Expr2:pNode) return pNode;\r
\r
function MkExprNode(Term,ExprPrime:pNode) return pNode;\r
function MkTermNode(Fact,TermPrime:pNode) return pNode;\r
function MkExprPrimeNode(Term,ExprPrime:pNode;anOperator:operator) return pNode;\r
function MkTermPrimeNode(Fact,TermPrime:pNode;anOperator:operator) return pNode;\r
\r
function MkFactNode(aNode:pNode) return pNode;\r
function MkIdNode(Val:Lexical.Lexeme) return pNode;\r
function MkNbNode(Val:integer) return pNode;\r
\r
function MkAffectNode(Id,Expr:pNode) return pNode;\r
function MkFaireNode(id1,id2:pNode) return pNode;\r
function MkRepeterNode(Expr,Instr:pNode) return pNode;\r
function MkSiNode(Cond,Instr,Sinon:pNode) return pNode;\r
function MkSinonNode(Instr:pNode) return pNode;\r
function MkAutempsNode(Expr,Instr:pNode) return pNode;\r
function MkAttendreNode(Expr:pNode) return pNode;\r
function MkCondNode(Expr1,Expr2:pNode;anOpRel:op_rel) return pNode;\r
\r
-- acces\r
function IdGetLex(aIdNode:pNode) return Lexical.Lexeme;\r
function NbGetValue(aNbNode:pNode) return Integer;\r
-- affectation\r
procedure IdSetValue(aIdNode:pNode;aVal:Lexical.Lexeme);\r
\r
-- affichage\r
procedure PrintTree(aNode:pNode);\r
\r
end Nodes;\r
With Reduct;\r
package product is\r
procedure OpenOutputFile(FileName:string:="outfile");\r
procedure CloseOutputFile;\r
procedure ProductTree(PtraReductTree:Reduct.pReductNode);\r
procedure PrintTree(PtraReductTree:Reduct.pReductNode);\r
end product;\r
With Calendar;\r
package Tic is\r
procedure StartTic;\r
procedure SetTicRate(TheRate:duration:=0.1);\r
procedure WaitForTic; -- bloquant pour l'appelant\r
procedure ReleaseTic;\r
end Tic;\r
package Bounded_Strings is\r
\r
type Variable_Strings (Length : positive) is private;\r
\r
procedure Free (The_String : in out Variable_Strings);\r
procedure Append (To_The_String : in out Variable_Strings;\r
The_Char : in character);\r
procedure Set (The_String : in out Variable_Strings;\r
With_String : in String);\r
procedure Affect (The_String : in out Variable_Strings;\r
With_String : in Variable_Strings);\r
\r
function To_Number (The_String : in Variable_Strings;\r
In_Base : in Positive) return Integer;\r
function Length (From_The_String : in Variable_Strings) return Natural;\r
function Image (From_The_String : in Variable_Strings) return String;\r
function Upper_Case_Image (From_The_String : in Variable_Strings) return String;\r
function Is_Equal (Left, Right : in Bounded_Strings.Variable_Strings)\r
return boolean;\r
Private\r
void : constant natural := 0;\r
Type Variable_Strings (Length : positive) is record\r
The_Length : natural := void;\r
The_Content : string (1..Length);\r
end record;\r
\r
end Bounded_Strings;\r
with Nodes;\r
with Lexical;\r
package Symbol is\r
\r
type Kind is (Category, Station, Actor, Variable, Effect,\r
Scene, Begining, Argument, NONE);\r
\r
type Types is (Binaire, Fugitif, Temporel, Discret,\r
T_Number, T_Effect, T_Scene, T_Station,\r
T_Category, T_Begining, T_Void, T_Error);\r
\r
Global_Table_Size: constant Positive := 32;\r
Local_Table_Size : constant Positive := 16;\r
Actor_Table_Size : constant Positive := 8;\r
\r
-- Creation/Liberation/Activation\r
\r
procedure New_Table (Length : in positive);\r
\r
-- Retour a la table globale\r
procedure Release_Table;\r
\r
-- Initialisation de la pile des tables\r
Procedure Init_Tables_Stack;\r
\r
-- Activation d'une table des symboles locale\r
procedure Set_Current_Table (Name : in Lexical.Lexeme);\r
\r
-- Desactivation de la table des symboles courante\r
procedure Reset_Current_Table;\r
\r
-- Modification\r
\r
-- Ajoute une entree a la table des symboles\r
procedure Add (The_Name : in Lexical.Lexeme; Of_Kind : in Kind);\r
\r
-- Rattache le code a un effet ou une scene\r
procedure Set_Code (Name : in Lexical.Lexeme; The_Code : in Nodes.pNode);\r
\r
-- Pour une station, une variable\r
procedure Set_Value (Name : in Lexical.Lexeme; The_Value : in Integer);\r
\r
-- Pour un argument\r
procedure Set_Arg_Value (With_Value : in Lexical.Lexeme;\r
Arg_Number : in Positive);\r
\r
-- Pour une variable, un acteur\r
procedure Set_Type (Name : in Lexical.Lexeme; The_Type : in Types);\r
\r
-- pour une station\r
procedure Set_Type (From_Station : in Lexical.Lexeme;\r
With_Category : in Lexical.Lexeme);\r
\r
-- Consultation\r
\r
-- Pour un effet ou une scene\r
function Get_Code (From_Name : in Lexical.Lexeme) return Nodes.pNode;\r
\r
-- Pour une station, une variable, un argument\r
function Get_Value (From_Name : in Lexical.Lexeme) return Integer;\r
\r
-- Pour un acteur\r
function Get_Actor_Number (In_Station : in Lexical.Lexeme;\r
From_actor : in Lexical.Lexeme) return Integer;\r
\r
-- Pour tout sauf un acteur\r
function Get_Type (From_Name : in Lexical.Lexeme) return Types;\r
\r
-- Pour un acteur\r
function Get_Type (In_Station : in Lexical.Lexeme;\r
From_actor : in Lexical.Lexeme) return Types;\r
\r
-- Tests\r
procedure Print;\r
\r
end Symbol;\r
With Symbol;\r
With Nodes;\r
With Lexical;\r
package Reduct is\r
Type ReductNodeList is (ACT,DES,MODI,EVO,NONE);\r
Type ReductNode(aReductNodeType:ReductNodeList);\r
Type pReductNode is access ReductNode;\r
Type ReductNode(aReductNodeType:ReductNodeList)\r
is record\r
TheType:ReductNodeList:=NONE;\r
TheTime:integer:=0;\r
Next:pReductNode:=null;\r
case aReductNodeType is\r
when ACT => Act_Periph:integer;\r
Act_Actor:integer;\r
when DES => Des_Periph:integer;\r
Des_Actor:integer;\r
when MODI => Mod_Periph:integer;\r
Mod_Actor:integer;\r
Mod_Nbre:integer;\r
when EVO => Evo_Periph:integer;\r
Evo_Actor:integer;\r
Evo_Nbre1,Evo_Nbre2:integer;\r
when NONE => null;\r
end case;\r
end record;\r
\r
function ReductTree(PtraAbstractTree:Nodes.pNode) return pReductNode;\r
-- tests\r
procedure printTree(aTreeNode:Nodes.pNode);\r
end Reduct;\r
\r
with Bounded_Strings;
package Lexical is
type Token is (L_Open, L_Close, L_Comma, L_Point, L_Plus, L_Minus,
L_Star, L_Slash, L_Equ, L_Affect, L_Neq, L_Gt, L_Lt,
L_Geq, L_Leq, L_Nbr, L_Id, L_Activer, L_Alors,
L_Attendre, L_Autemps, L_Avec, L_Binaire, L_Categorie,
L_Debut, L_Desactiver, L_Discret, L_Effet, L_En,
L_Est, L_Evoluer, L_Experience, L_Faire, L_Fin,
L_Fois, L_Fugitif, L_Implantation, L_Jusqua, L_Materiel,
L_Mod, L_Modifier, L_Repeter, L_Scene,
L_Si, L_Sinon, L_Spectacle, L_Temporel, L_Unk, L_Eof);
subtype Lexeme is Bounded_Strings.Variable_Strings (80);
procedure Open (File_Name : in String);
function At_End return Boolean;
procedure Next;
function Get return Token;
function Value return Lexeme;
function Number return Integer;\r
function Line_Number return Positive;\r
function Column_Number return Positive;\r
procedure Close;
end Lexical;
package Look_Ahead is
type Object is private;
function Is_Existing (The_Look_Ahead : Object) return Boolean;
procedure Value (The_Look_Ahead : in out Object; Char : out Character);
procedure Affect (The_Look_Ahead : in out Object;
With_The_Char : in Character);
private
type Object is
record
Existence : Boolean := False;
Content : Character;
end record;
end Look_Ahead;
with Nodes;\r
package Parser is
procedure Parse_File (File_Name : in String;Ptr_Start: out Nodes.pNode);
end Parser;
package Error is\r
\r
type Grammar is (Show,Bloc_materiel,Bloc_implantation,Bloc_experience,\r
Prog_principal,Corps_materiel);\r
\r
type Collection is (Divide_by_Zero, Negativ_Number,Bitbus_Error);\r
\r
Internal : constant boolean := true;\r
External : constant boolean := false; -- erreur sur le fichier source\r
\r
procedure Handle (Message:in String;Item:in Grammar);\r
procedure Handle (anErrorClass:in Collection);\r
procedure Handle (Message:in String;Internal:in Boolean);\r
\r
end Error;\r
generic\r
Size : in positive := 10;\r
Type Element is private;\r
\r
package Gen_Stack is\r
type Object is limited private;\r
\r
procedure Push (On : in out Object; The_Object : in Element);\r
procedure Pop (From : in out Object);\r
function Get_Top (From : in Object) return Element;\r
function Is_Full (The_Stack : in Object) return boolean;\r
function Is_Empty (The_Stack : in Object) return boolean;\r
\r
private\r
type Content is array (1..Size) of Element;\r
type Object is\r
record\r
The_Top : Integer := 0; -- Vide\r
The_Content : Content;\r
end record;\r
end Gen_Stack;\r
WITH Etape,Text_IO,Formate;\r
Package body Role is\r
Package int_IO is new Text_IO.INTEGER_IO(integer);\r
\r
Procedure AfficherUnRole(R:Role) is\r
USE Etape;\r
E:Etape.Etape;\r
begin\r
Text_IO.New_Line;\r
Text_IO.Put("Acteur : ");Int_IO.Put(LacteurDuRole(R).Peripherique);\r
Text_IO.Put(" ");Int_IO.Put(LacteurDuRole(R).Numero_Fonction);\r
Text_IO.New_line;\r
Text_IO.Put("Les Etapes : ");\r
E:=LesEtapesDuRole(R);\r
while E/=Etape.EtapeInexistante loop\r
Etape.AfficherUneEtape(E);\r
E:=Etape.LaSuiteDeLetape(E);\r
end loop;\r
Text_IO.New_Line;\r
Text_IO.Put("En Cours : ");if LeRoleEstEnCours(R) then Text_IO.Put("VRAIE");\r
else Text_IO.Put("FAUX");\r
end if;Text_IO.New_Line;\r
Text_IO.Put("Le Debut : ");Int_IO.Put(LeDebutDuRole(R));Text_IO.New_line;\r
Text_IO.Put("L'index : ");Text_IO.New_line;\r
Text_IO.Put("La Duree : ");Int_IO.Put(LaDureeDuRole(R));Text_IO.New_Line;\r
end AfficherUnRole;\r
\r
\r
PROCEDURE Executer(Qui:Acteur;Quoi:Etape.Action) is\r
BEGIN\r
if Quoi.Valeur1=0 and then Quoi.Valeur2=0 then\r
Text_IO.Put('D' &\r
Formate.IntToStr(Qui.Peripherique,2) &\r
Formate.IntToStr(Qui.Numero_Fonction,2) &\r
Formate.IntToStr(Quoi.Valeur1,4) &\r
'F');\r
else\r
Text_IO.Put('D' &\r
Formate.IntToStr(Qui.Peripherique,2) &\r
Formate.IntToStr(Qui.Numero_Fonction,2) &\r
Formate.IntToStr(Quoi.Valeur1,4) &\r
Formate.IntToStr(Quoi.Valeur2,4) &\r
'F');\r
end if;\r
Text_IO.New_Line;\r
END Executer;\r
\r
PROCEDURE SauvegarderLeTemps(F:Text_IO.File_Type;UnTemps:Etape.Temps) is\r
BEGIN\r
Int_IO.Put(F,UnTemps);\r
END SauvegarderLeTemps;\r
\r
PROCEDURE SauvegarderLacteur(F:Text_IO.File_Type;UnActeur:Acteur) is\r
begin\r
Int_IO.Put(F,UnActeur.Peripherique);\r
Int_IO.Put(F,UnActeur.Numero_Fonction);\r
end SauvegarderLacteur;\r
\r
PROCEDURE SauvegarderLaction(F:Text_IO.File_Type;UneAction:Etape.Action) is\r
begin\r
Int_IO.Put(F,UneAction.Valeur1);\r
Int_IO.Put(F,UneAction.Valeur2);\r
end SauvegarderLaction;\r
\r
\r
-- creation\r
FUNCTION CreerUnRole(A:Acteur) return Role is\r
Resultat:Role;\r
BEGIN\r
Resultat:=NEW DescripteurDeRole;\r
Resultat.Lacteur:=A;\r
Resultat.LesEtapes:=Etape.EtapeInexistante;\r
Resultat.EnCours:=FALSE;\r
Resultat.LeDebut:=0; -- temps\r
Resultat.Lindex:=Etape.EtapeInexistante;\r
Resultat.LaDuree:=0;\r
return Resultat;\r
END CreerUnRole;\r
\r
FUNCTION ChargerUnActeur(F:IN Text_IO.File_Type) return Acteur is\r
Adr_Periph,Num_Fonc:INTEGER;\r
ActAux:Acteur;\r
BEGIN\r
Int_IO.Get(F,Adr_Periph);\r
Int_IO.Get(F,Num_Fonc);\r
ActAux.Peripherique:=Adresse_Peripherique'(Adr_Periph);\r
ActAux.Numero_Fonction:=Natural'(Num_Fonc);\r
return ActAux;\r
END ChargerUnActeur;\r
\r
FUNCTION ChargerUneAction(F:IN Text_IO.File_Type) return Etape.Action is\r
ActionAux:Etape.Action;\r
val1,val2:Integer;\r
BEGIN\r
Int_IO.Get(F,val1);\r
Int_IO.Get(F,val2);\r
ActionAux.Valeur1:=val1;\r
ActionAux.Valeur2:=val2;\r
return ActionAux;\r
END ChargerUneAction;\r
\r
FUNCTION ChargerUnTemps(F:IN Text_IO.File_Type) return Etape.Temps is\r
i:INTEGER;\r
TempsAux:Etape.Temps;\r
BEGIN\r
Int_IO.Get(F,i);\r
TempsAux:=Etape.Temps'(i);\r
return TempsAux;\r
END ChargerUnTemps;\r
\r
FUNCTION ChargerUnRole(F:IN Text_IO.File_Type) return Role is\r
UnRole:Role;UnActeur:Acteur;\r
UneAction:Etape.Action;UnTemps:Etape.Temps;\r
Nombre:INTEGER;\r
BEGIN\r
UnActeur:=ChargerUnActeur(F);\r
UnRole:=CreerUnRole(UnActeur);\r
Int_IO.Get(F,Nombre);\r
FOR i IN 1..Nombre LOOP\r
UneAction:=ChargerUneAction(F);\r
UnTemps:=ChargerUnTemps(F);\r
CaserUneActionDansLeRole(UnRole,UnTemps,UneAction);\r
END LOOP;\r
return UnRole;\r
END ChargerUnRole;\r
\r
-- acces\r
FUNCTION LeNombreDactionsDuRole(UnRole:Role) return INTEGER is\r
USE Etape;\r
compteur:INTEGER:=0;\r
ptrEtape:Etape.Etape;\r
BEGIN\r
ptrEtape:=LesEtapesDuRole(UnRole);\r
while ptrEtape/= Etape.EtapeInexistante loop\r
compteur:=compteur+1;\r
ptrEtape:=Etape.LaSuiteDeLetape(ptrEtape);\r
end loop;\r
return compteur;\r
END LeNombreDactionsDuRole;\r
\r
FUNCTION LeRoleEstVide(UnRole:Role) return BOOLEAN is\r
USE Etape;\r
BEGIN\r
return UnRole.LesEtapes=Etape.EtapeInexistante;\r
END LeRoleEstVide;\r
\r
FUNCTION LacteurDuRole(UnRole:Role) return Acteur is\r
BEGIN\r
return UnRole.Lacteur;\r
END LacteurDuRole;\r
\r
FUNCTION LaDureeDuRole(UnRole:Role) return Etape.Temps is\r
BEGIN\r
return UnRole.LaDuree;\r
END LaDureeDuRole;\r
\r
FUNCTION LeRoleEstEnCours(UnRole:Role) return BOOLEAN is\r
BEGIN\r
return UnRole.EnCours;\r
END LeRoleEstEnCours;\r
\r
FUNCTION LeDebutDuRole(UnRole:Role) return Etape.Temps is\r
begin\r
return UnRole.LeDebut;\r
end LeDebutDuRole;\r
\r
FUNCTION LesEtapesDuRole(UnRole:Role) return Etape.Etape is\r
BEGIN\r
return UnRole.LesEtapes;\r
END LesEtapesDuRole;\r
\r
PROCEDURE QuelleActionDuRole(UnRole:Role;UnTemps:Etape.Temps;\r
UneAction: out Etape.Action;\r
Existe: out BOOLEAN) is\r
USE Etape;\r
indexRole:Etape.Etape;\r
trouve: BOOLEAN:=FALSE;\r
BEGIN\r
Existe:=FALSE;\r
IndexRole:=LesEtapesDuRole(UnRole);\r
WHILE IndexRole/=Etape.EtapeInexistante and then not trouve loop\r
IF Etape.LeTempsDeLetape(IndexRole)=UnTemps THEN\r
Existe:=TRUE;\r
trouve:=TRUE;\r
UneAction:=Etape.LactionDeLetape(IndexRole);\r
END IF;\r
IndexRole:=Etape.LaSuiteDeLetape(IndexRole);\r
END loop;\r
END QuelleActionDuRole;\r
\r
-- modification\r
PROCEDURE CaserUneActionDansLeRole(UnRole:in out Role;UnTemps:Etape.Temps;\r
UneAction:Etape.Action) is\r
E:Etape.Etape;\r
BEGIN\r
E:=LesEtapesDuRole(UnRole);\r
Etape.CaserUneActionDansLesEtapes(UnTemps,UneAction,E);\r
if UnTemps>UnRole.LaDuree then UnRole.LaDuree:=UnTemps;\r
end if;\r
UnRole.LesEtapes:=E;\r
END CaserUneActionDansLeRole;\r
\r
PROCEDURE ExclureUneActionDuRole(UnRole:in out Role;UnTemps:Etape.Temps) is\r
USE Etape;\r
E:Etape.Etape;\r
LeTemps:Etape.temps;\r
BEGIN\r
E:=LesEtapesDuRole(UnRole);\r
Etape.ExclureUneActionDesEtapes(E,UnTemps);\r
if UnTemps=UnRole.LaDuree then\r
UnRole.LaDuree:=0;\r
E:=LesEtapesDuRole(UnRole);\r
while E/=Etape.EtapeInexistante loop\r
LeTemps:=Etape.LeTempsDeLetape(E);\r
if LeTemps>UnRole.LaDuree then\r
UnRole.LaDuree:=LeTemps;\r
end if;\r
E:=Etape.LaSuiteDeLetape(E);\r
end loop;\r
end if;\r
END ExclureUneActionDuRole;\r
\r
PROCEDURE DecalerUneActionDuRole(UnRole:in out Role;UnTemps:Etape.Temps;\r
UnDelai:Delai) is\r
USE Etape;\r
NouveauTemps:Etape.Temps;\r
BEGIN\r
NouveauTemps:=UnTemps+Etape.Temps(UnDelai);\r
if NouveauTemps>=0 then\r
DeplacerUneActionDuRole(UnRole,UnTemps,NouveauTemps);\r
else\r
null;\r
end if;\r
END DecalerUneActionDuRole;\r
\r
PROCEDURE DeplacerUneActionDuRole(UnRole:in out Role;Ancien:Etape.Temps;\r
Nouveau:Etape.Temps) is\r
UneAction:Etape.Action;\r
Existe:BOOLEAN;\r
BEGIN\r
QuelleActionDuRole(UnRole,Ancien,UneAction,Existe);\r
if Existe then\r
ExclureUneActionDuRole(UnRole,Ancien);\r
CaserUneActionDansLeRole(UnRole,Nouveau,UneAction);\r
end if;\r
END DeplacerUneActionDuRole;\r
\r
PROCEDURE DecalerLeRole(UnRole:in out Role;UnDelai:Delai) is\r
USE Etape;\r
UneEtape:Etape.Etape;\r
LeTemps:Etape.Temps;\r
BEGIN\r
if not LeRoleEstVide(UnRole) then\r
UneEtape:=LesEtapesDuRole(UnRole);\r
if Etape.LeTempsDeLetape(UneEtape) + UnDelai >= 0 then\r
while UneEtape/=Etape.EtapeInexistante loop\r
LeTemps:=Etape.LeTempsDeLetape(UneEtape) + UnDelai;\r
Etape.ChangerLeTempsDeLetape(UneEtape,LeTemps);\r
end loop;\r
UnRole.LaDuree:=UnRole.LaDuree+UnDelai;\r
else\r
null;\r
end if;\r
end if;\r
END DecalerLeRole;\r
\r
PROCEDURE ViderLeRole(UnRole:IN OUT Role) is\r
USE Etape;\r
EtapeAjeter:Etape.Etape;\r
BEGIN\r
while UnRole.LesEtapes/= Etape.EtapeInexistante loop\r
EtapeAjeter:=UnRole.LesEtapes;\r
UnRole.LesEtapes:=Etape.LaSuiteDeLetape(EtapeAjeter);\r
Etape.DetruireLetape(EtapeAjeter);\r
end loop;\r
END ViderleRole;\r
\r
-- execution\r
PROCEDURE DemarrerLeRole(UnRole:IN OUT Role) is\r
USE Etape;\r
BEGIN\r
UnRole.Lindex:=LesEtapesDuRole(UnRole);\r
IF UnRole.Lindex/=Etape.EtapeInexistante THEN\r
UnRole.EnCours:=TRUE;\r
UnRole.LeDebut:=0;\r
END IF;\r
END DemarrerLeRole;\r
\r
PROCEDURE ArreterLeRole(UnRole:IN OUT Role) is\r
BEGIN\r
UnRole.EnCours:=FALSE;\r
END ArreterLeRole;\r
\r
PROCEDURE SolliciterLeRole(UnRole:in out Role;TempsCourant:integer) is\r
USE Etape;\r
Qui:Acteur;\r
Quoi:Etape.Action;\r
BEGIN\r
if LeRoleEstEnCours(UnRole) then\r
if Etape.LeTempsDeLetape(UnRole.Lindex) <= TempsCourant then \r
Qui:=LacteurDuRole(UnRole);\r
Quoi:=Etape.LactionDeLetape(UnRole.Lindex);\r
Executer(Qui,Quoi);\r
UnRole.Lindex:=Etape.LaSuiteDeLetape(UnRole.Lindex);\r
if UnRole.Lindex=Etape.EtapeInexistante then ArreterLeRole(UnRole);\r
end if;\r
else\r
null;\r
end if;\r
end if;\r
END SolliciterLeRole;\r
\r
-- sauvegarde\r
PROCEDURE SauvegarderLeRole(UnRole:Role;Fichier:STRING) is\r
USE Etape;\r
UneEtape:Etape.Etape;\r
F:Text_IO.File_Type;\r
BEGIN\r
SauvegarderLacteur(F,LacteurDuRole(UnRole));\r
Int_IO.Put(F,LeNombreDactionsDuRole(UnRole));\r
UneEtape:=LesEtapesDuRole(UnRole);\r
while UneEtape/=Etape.EtapeInexistante loop\r
SauvegarderLeTemps(F,Etape.LeTempsDeLetape(UneEtape));\r
SauvegarderLaction(F,Etape.LactionDeLetape(UneEtape));\r
UneEtape:=Etape.LaSuiteDeLetape(UneEtape);\r
end loop;\r
END SauvegarderLeRole;\r
END Role;\r
\r
With Text_IO;\r
Package body Etape is\r
package Int_IO is new Text_IO.Integer_IO(Integer);\r
PROCEDURE AfficherUneEtape(E:Etape) is\r
UnTemps:Temps;\r
UneAction:Action;\r
BEGIN\r
IF E/=EtapeInexistante THEN\r
UnTemps:=LeTempsDeLetape(E);\r
UneAction:=LactionDeLetape(E);\r
Text_IO.Put("Temps : ");Int_IO.Put(UnTemps);\r
Text_IO.Put(" Action : ");Int_IO.Put(UneAction.valeur1);\r
Text_IO.Put(" ");Int_IO.Put(UneAction.valeur2);\r
Text_IO.New_Line;\r
ELSE\r
Text_IO.Put_Line("Pointeur NIL , erreur");\r
end if;\r
END AfficherUneEtape;\r
\r
\r
FUNCTION CreerUneEtape(UnTemps:temps;UneAction:Action;UneEtape:Etape) return Etape is\r
EtapeAux:Etape;\r
BEGIN\r
EtapeAux:= NEW CelluleEtape;\r
EtapeAux.LeTemps:=UnTemps;\r
EtapeAux.Laction:=UneAction;\r
EtapeAux.LaSuite:=UneEtape;\r
return EtapeAux;\r
END;\r
\r
FUNCTION LeTempsDeLetape(UneEtape:Etape) return Temps is\r
BEGIN\r
return UneEtape.LeTemps;\r
END;\r
\r
FUNCTION LactionDeLetape(UneEtape:Etape) return Action is\r
BEGIN\r
return UneEtape.Laction;\r
END;\r
\r
FUNCTION LaSuiteDeLetape(UneEtape:Etape) return Etape is\r
BEGIN\r
return UneEtape.LaSuite;\r
END;\r
\r
PROCEDURE ChangerLeTempsDeLetape(UneEtape: IN OUT Etape;UnTemps:temps) is\r
BEGIN\r
UneEtape.LeTemps:=UnTemps;\r
END;\r
\r
PROCEDURE ChangerLactionDeLetape(UneEtape:IN OUT Etape;UneAction:Action) is\r
BEGIN\r
UneEtape.Laction:=UneAction;\r
END;\r
\r
-- rmq : L'etape E qui est retournee est la meme que celle transmise\r
-- elle n'est pas modifiee mais doit etre passee par adresse pour que\r
-- des affectations ( insertions) puissent se faire pdt la recursion arriere\r
PROCEDURE CaserUneActionDansLesEtapes(T:temps;A:Action;E:IN OUT Etape) is\r
BEGIN\r
IF E = EtapeInexistante THEN -- OK\r
E:=CreerUneEtape(T,A,E);\r
ELSE\r
IF T = LeTempsDeLetape(E) THEN -- OK\r
ChangerLactionDeLetape(E,A);\r
ELSE\r
IF T > LeTempsDeLetape(E) THEN -- OK\r
CaserUneActionDansLesEtapes(T,A,E.LaSuite);\r
ELSE\r
E:=CreerUneEtape(T,A,E); -- OK\r
END IF;\r
END IF;\r
END IF;\r
END;\r
\r
PROCEDURE DetruireLetape(E:IN OUT Etape) is\r
BEGIN\r
E:=EtapeInexistante;\r
END;\r
\r
PROCEDURE ExclureUneActionDesEtapes(E:IN OUT Etape;T:temps) is\r
A_Jeter:Etape;\r
BEGIN\r
IF E/= EtapeInexistante THEN -- OK\r
IF T = LeTempsDeLetape(E) THEN\r
BEGIN\r
A_Jeter:=E;\r
E:=E.LaSuite;\r
DetruireLEtape(A_Jeter); -- OK\r
END;\r
ELSE\r
IF T > LeTempsDeLetape(E) THEN -- OK\r
ExclureUneActionDesEtapes(E.LaSuite,T);\r
END IF;\r
END IF;\r
END IF;\r
END;\r
END Etape;\r
With Etape;\r
With Role;\r
With Text_IO;\r
With Tic;\r
package body Scene is\r
package Int_IO is new Text_IO.Integer_IO(Integer);\r
TempsDerniereAction:Natural:=0;\r
ChronoCourant:integer := 0;\r
TicRate:Duration := 0.1; -- lie a Bitbus\r
\r
Procedure CreerUneScene(UneScene:in out Scene) is\r
begin\r
UneScene:=New DescripteurDeScene;\r
UneScene.NbreScriptes:=0;\r
for i in 1..NbScriptes loop\r
UneScene.Contenu(i).Nom:=Role.Adresse_Vide;\r
for j in 1..NbRoles loop\r
UneScene.Contenu(i).Contenu(j):=Role.Role_Vide;\r
end loop;\r
end loop;\r
end CreerUneScene;\r
\r
Procedure DetruireUneScene(UneScene:in out Scene) is\r
begin\r
null;\r
end DetruireUneScene;\r
\r
Function ChargerUneOperation(F:Text_IO.File_Type) return Operation is\r
UnActeur:Role.Acteur;\r
UnTemps:Etape.Temps;\r
UneAction:Etape.Action;\r
UneOperation:Operation;\r
begin\r
UnActeur:=Role.ChargerUnActeur(F);\r
UnTemps:=Role.ChargerUntemps(F);\r
UneAction:=Role.ChargerUneAction(F);\r
\r
\r
UneOperation.Temps:=UnTemps;\r
\r
if UnTemps>TempsDerniereAction then\r
TempsDerniereAction:=UnTemps;\r
end if;\r
\r
UneOperation.Acteur:=UnActeur;\r
UneOperation.Action:=UneAction;\r
\r
return UneOperation;\r
end ChargerUneOperation;\r
\r
Procedure ScripteExiste(UneOperation:Operation;UneScene:in out Scene;\r
Existe:in out Boolean;\r
Indice_Scripte:in out Natural) is\r
Begin\r
Indice_Scripte:=1;\r
Existe:=FALSE;\r
while Indice_Scripte<=NbScriptes and then not Existe loop\r
if UneScene.Contenu(Indice_Scripte).Nom=UneOperation.Acteur.Peripherique\r
then\r
Existe:=TRUE;\r
else\r
Indice_Scripte:=Indice_Scripte+1;\r
end if;\r
end loop;\r
End ScripteExiste;\r
\r
Procedure RoleExiste(UneOperation:Operation;UnScripte:in out Scripte;\r
Existe:in out Boolean;Indice_Role:in out Natural) is\r
Use Role;\r
Begin\r
Indice_Role:=1;\r
Existe:=FALSE;\r
while Indice_Role<=NbRoles and then not Existe loop\r
if UnScripte.Contenu(Indice_Role)/=Role.Role_Vide and then\r
UnScripte.Contenu(Indice_Role).Lacteur.Numero_Fonction=\r
UneOperation.Acteur.Numero_Fonction then\r
Existe:=TRUE;\r
else\r
Indice_Role:=Indice_Role+1;\r
end if;\r
end loop;\r
End RoleExiste;\r
\r
Function TrouverScripteLibre(UneScene:in Scene) return Natural is\r
Indice_Scripte:Natural:=1;\r
Trouve:Boolean:=FALSE;\r
begin\r
while Indice_Scripte<=NbScriptes and then not Trouve loop\r
if UneScene.Contenu(Indice_Scripte).Nom=Role.Adresse_Vide then\r
return Indice_Scripte;\r
end if;\r
Indice_Scripte:=Indice_Scripte+1;\r
end loop;\r
end TrouverScripteLibre;\r
\r
Procedure CreerUnScripte(UnActeur:in Role.Acteur;UneScene:in out Scene;\r
Indice_Scripte:in out Natural) is\r
Begin\r
Indice_Scripte:=TrouverScripteLibre(UneScene);\r
UneScene.Contenu(Indice_Scripte).Nom:=UnActeur.Peripherique;\r
End CreerUnScripte;\r
\r
Function TrouverRoleLibre(UnScripte:in Scripte) return Natural is\r
Use Role;\r
Indice_Role:Natural:=1;\r
Trouve:Boolean:=FALSE;\r
begin\r
while Indice_Role<=NbRoles and then not Trouve loop\r
if UnScripte.Contenu(Indice_Role)=Role.Role_Vide then\r
return Indice_Role;\r
end if;\r
Indice_Role:=Indice_Role+1;\r
end loop;\r
end TrouverRoleLibre;\r
\r
Procedure CreerRoleDansScripte(UnActeur:in Role.Acteur;\r
UnScripte:in out Scripte;\r
Indice_Role:in out Natural) is\r
UnRole:Role.Role;\r
Begin\r
Indice_Role:=TrouverRoleLibre(UnScripte);\r
UnRole:=Role.CreerUnRole(UnActeur);\r
UnScripte.Contenu(Indice_Role):=UnRole;\r
End CreerRoleDansScripte;\r
\r
Procedure TraiterUneOperation(UneOperation:in Operation;\r
UneScene:in out Scene) is\r
Indice_Scripte:Natural:=1;\r
Indice_Role:Natural:=1;\r
Existe:Boolean:=FALSE;\r
UnRole:Role.Role;\r
begin\r
-- recherche si le scripte lie au peripherique existe\r
ScripteExiste(UneOperation,UneScene,Existe,Indice_Scripte);\r
-- creation si n'existe pas\r
if not Existe then\r
CreerUnScripte(UneOperation.Acteur,UneScene,Indice_Scripte);\r
end if;\r
-- a partir de la, on travaille sur un scripte particulier :\r
-- UneScene.Contenu(Indice_Scripte)\r
-- recherche si le role (ou acteur) du scripte existe\r
RoleExiste(UneOperation,UneScene.Contenu(Indice_Scripte),Existe,\r
Indice_Role);\r
if not Existe then\r
CreerRoleDansScripte(UneOperation.Acteur,UneScene.\r
Contenu(Indice_Scripte),Indice_Role);\r
end if;\r
-- on travaille sur un role particulier :\r
-- UneScene.Contenu(Indice_Scripte).Contenu(Indice_Role)\r
-- Inserer Action dans une etape de l'acteur avec UnTemps comme clef\r
Role.CaserUneActionDansLeRole(UneScene.Contenu(Indice_Scripte).\r
Contenu(Indice_Role),UneOperation.Temps,UneOperation.Action);\r
end TraiterUneOperation;\r
\r
Function ChargerUneScene(F:Text_IO.File_Type) return Scene is\r
UneOperation:Operation;\r
UneScene:Scene;\r
begin\r
CreerUneScene(UneScene);\r
While not Text_IO.End_Of_File(F) loop\r
UneOperation:=ChargerUneOperation(F);\r
TraiterUneOperation(UneOperation,UneScene);\r
if Text_IO.End_Of_Line(F) then Text_IO.Skip_Line(F);\r
end if;\r
end loop;\r
return UneScene;\r
end ChargerUneScene;\r
\r
Procedure AfficherUnScripte(UnScripte:in Scripte) is\r
Use Role;\r
UnRole:Role.Role;\r
begin\r
for Indice_Role in 1..NbRoles loop\r
UnRole:=UnScripte.Contenu(Indice_Role);\r
if UnRole/=Role.Role_Vide then\r
Role.AfficherUnRole(UnRole);\r
end if;\r
end loop;\r
end AfficherUnScripte;\r
\r
Procedure AfficherUneScene(UneScene:in Scene) is\r
UnScripte:Scripte;\r
begin\r
for indice_Scripte in 1..NbScriptes loop\r
UnScripte:=UneScene.Contenu(Indice_Scripte);\r
if UnScripte.Nom/=Role.Adresse_Vide then\r
AfficherUnScripte(UnScripte);\r
end if;\r
end loop;\r
end AfficherUneScene;\r
\r
Procedure JouerUneScene(UneScene:in out Scene) is -- bloquant\r
Use Role;\r
begin\r
for indice_Scripte in 1..NbScriptes loop\r
for indice_Role in 1..NbRoles loop\r
if UneScene.Contenu(Indice_Scripte).Contenu(Indice_Role)/=\r
Role.Role_Vide then\r
Role.DemarrerLeRole(UneScene.Contenu(Indice_Scripte).\r
Contenu(Indice_Role));\r
end if;\r
end loop;\r
end loop;\r
Tic.SetTicRate(TicRate); -- par defaut TicRate = 0.1 s\r
while ChronoCourant<=TempsDerniereAction loop\r
Tic.StartTic;\r
for indice_Scripte in 1..NbScriptes loop\r
for indice_Role in 1..NbRoles loop\r
if UneScene.Contenu(Indice_Scripte).Contenu(Indice_Role)/=\r
Role.Role_Vide then\r
Role.SolliciterLeRole(UneScene.Contenu(Indice_Scripte).\r
Contenu(Indice_Role),chronoCourant);\r
end if;\r
end loop;\r
end loop;\r
Tic.WaitForTic; -- attente bloquante\r
ChronoCourant:=ChronoCourant+integer(10*TicRate); \r
-- TicRate en s , Chrono courant en 1/10 de s\r
end loop;\r
Tic.ReleaseTic;\r
end JouerUneScene;\r
\r
end Scene;\r
With Text_IO;\r
package body Formate is\r
Function IntToStr(UnNombre:Natural;NbChiffres:Positive) return string is\r
UneChaine:String(1..NbChiffres+1);\r
Nbre:Natural:=0;\r
NbAux:Natural:=UnNombre;\r
begin\r
if NbAux=0 then\r
Nbre:=1;\r
else\r
While NbAux/=0 loop\r
NbAux:=NbAux/10;\r
Nbre:=Nbre+1;\r
end loop;\r
end if;\r
UneChaine(1..Nbre+1):=Integer'image(Integer(UnNombre));\r
UneChaine(1):='0';\r
if Nbre=NbChiffres then\r
return UneChaine(2..Nbre+1);\r
else\r
return String'(1..NbChiffres-Nbre-1=>'0') & UneChaine(1..Nbre+1);\r
end if;\r
end IntToStr;\r
end Formate;\r
With Text_IO;\r
package body product is\r
package Int_IO is new Text_IO.Integer_IO(Integer);\r
\r
F:Text_IO.File_Type;\r
\r
procedure OpenOutputFile(FileName:string:="outfile") is\r
begin\r
Text_IO.Create(File=>F,Mode=>Text_IO.Out_File,Name=>FileName);\r
end OpenOutputFile;\r
\r
procedure CloseOutputFile is\r
begin\r
Text_IO.Close(F);\r
end CloseOutputFile;\r
\r
procedure SendToFile(value1,value2,value3,value4,value5:integer) is\r
begin\r
Int_IO.Put(F,value1);\r
Int_IO.Put(F,value2);\r
Int_IO.Put(F,value3);\r
Int_IO.Put(F,value4);\r
Int_IO.Put(F,value5);\r
Text_IO.New_Line(F);\r
end SendToFile;\r
\r
procedure ProductActiver(ptr:Reduct.pReductNode) is\r
periph,actor,time:integer;\r
begin\r
periph:=ptr.Act_periph;\r
actor:=ptr.Act_actor;\r
time:=ptr.TheTime;\r
SendToFile(periph,actor,Time,1,0);\r
end ProductActiver;\r
\r
procedure ProductDesactiver(ptr:Reduct.pReductNode) is\r
periph,actor,time:integer;\r
begin\r
periph:=ptr.Des_periph;\r
actor:=ptr.Des_actor;\r
time:=ptr.TheTime;\r
SendToFile(periph,actor,time,0,0);\r
end ProductDesactiver;\r
\r
procedure ProductModifier(ptr:Reduct.pReductNode) is\r
periph,actor,value1,time:integer;\r
begin\r
periph:=ptr.Mod_periph;\r
actor:=ptr.Mod_actor;\r
value1:=ptr.Mod_Nbre;\r
time:=ptr.TheTime;\r
SendToFile(periph,actor,time,value1,0);\r
end ProductModifier;\r
\r
procedure ProductEvoluer(ptr:Reduct.pReductNode) is\r
periph,actor,value1,value2,time:integer;\r
begin\r
periph:=ptr.Evo_periph;\r
actor:=ptr.Evo_actor;\r
value1:=ptr.Evo_Nbre1;\r
value2:=ptr.Evo_Nbre2;\r
time:=ptr.TheTime;\r
SendToFile(periph,actor,time,value1,value2);\r
end ProductEvoluer;\r
\r
procedure ProductTree(PtraReductTree:Reduct.pReductNode) is\r
Use Reduct;\r
ptr:Reduct.pReductNode;\r
begin\r
ptr:=PtraReductTree;\r
while ptr/=null loop\r
case ptr.TheType is\r
when ACT => ProductActiver(ptr);\r
when DES => ProductDesactiver(ptr);\r
when MODI => ProductModifier(ptr);\r
when EVO => ProductEvoluer(ptr);\r
when NONE => null;\r
end case;\r
ptr:=ptr.Next;\r
end loop;\r
end ProductTree;\r
\r
-- Tests affichage\r
procedure PrintActiver(ptr:Reduct.pReductNode) is\r
periph,actor,time:integer;\r
begin\r
periph:=ptr.Act_periph;\r
actor:=ptr.Act_actor;\r
time:=ptr.TheTime;\r
Text_IO.Put_Line(integer'image(periph)&" "&integer'image(actor)\r
&" "&integer'image(time)&" 1 0");\r
end PrintActiver;\r
\r
procedure PrintDesactiver(ptr:Reduct.pReductNode) is\r
periph,actor,time:integer;\r
begin\r
periph:=ptr.Des_periph;\r
actor:=ptr.Des_actor;\r
time:=ptr.TheTime;\r
Text_IO.Put_Line(integer'image(periph)&" "&integer'image(actor)\r
&" "&integer'image(time)&" 0 0");\r
end PrintDesactiver;\r
\r
procedure PrintModifier(ptr:Reduct.pReductNode) is\r
periph,actor,value1,time:integer;\r
begin\r
periph:=ptr.Mod_periph;\r
actor:=ptr.Mod_actor;\r
value1:=ptr.Mod_Nbre;\r
time:=ptr.TheTime;\r
Text_IO.Put_Line(integer'image(periph)&" "&integer'image(actor)\r
&" "&integer'image(time)&" "&integer'image(value1)&" 0");\r
end PrintModifier;\r
\r
procedure PrintEvoluer(ptr:Reduct.pReductNode) is\r
periph,actor,value1,value2,time:integer;\r
begin\r
periph:=ptr.Evo_periph;\r
actor:=ptr.Evo_actor;\r
value1:=ptr.Evo_Nbre1;\r
value2:=ptr.Evo_Nbre2;\r
time:=ptr.TheTime;\r
Text_IO.Put_Line(integer'image(periph)&" "&integer'image(actor)\r
&" "&integer'image(time)&integer'image(value1)\r
&" "&integer'image(value2));\r
end PrintEvoluer;\r
\r
procedure PrintTree(PtraReductTree:Reduct.pReductNode) is\r
Use Reduct;\r
ptr:Reduct.pReductNode;\r
begin\r
ptr:=PtraReductTree;\r
while ptr/=null loop\r
case ptr.TheType is\r
when ACT => PrintActiver(ptr);\r
when DES => PrintDesactiver(ptr);\r
when MODI => PrintModifier(ptr);\r
when EVO => PrintEvoluer(ptr);\r
when NONE => null;\r
end case;\r
ptr:=ptr.Next;\r
end loop;\r
end PrintTree;\r
\r
end Product;\r
With Text_IO;\r
package body Nodes is\r
package Int_IO is new Text_IO.Integer_IO(Integer);\r
\r
function MkActiverNode(id1,id2:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Activer);\r
ptrNode.TheType:=Activer;\r
ptrNode.Act_id1:=id1;\r
ptrNode.Act_id2:=id2;\r
return ptrNode;\r
end MkActiverNode;\r
\r
function MkDesactiverNode(id1,id2:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Desactiver);\r
ptrNode.TheType:=Desactiver;\r
ptrNode.Des_id1:=id1;\r
ptrNode.Des_id2:=id2;\r
return ptrNode;\r
end MkDesactiverNode;\r
\r
function MkModifierNode(id1,id2,Expr:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Modifier);\r
ptrNode.TheType:=Modifier;\r
ptrNode.Mod_id1:=id1;\r
ptrNode.Mod_id2:=id2;\r
ptrNode.Mod_Expr:=Expr;\r
return ptrNode;\r
end MkModifierNode;\r
\r
function MkEvoluerNode(id1,id2,Expr1,Expr2:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Evoluer);\r
ptrNode.TheType:=Evoluer;\r
ptrNode.Evo_id1:=id1;\r
ptrNode.Evo_id2:=id2;\r
ptrNode.Evo_Expr1:=Expr1;\r
ptrNode.Evo_Expr2:=Expr2;\r
return ptrNode;\r
end MkEvoluerNode;\r
\r
function MkExprNode(Term,ExprPrime:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Expression);\r
ptrNode.TheType:=Expression;\r
ptrNode.Exp_ExprPrime:=ExprPrime;\r
ptrNode.Exp_Term:=Term;\r
return ptrNode;\r
end MkExprNode;\r
\r
function MkExprPrimeNode(Term,ExprPrime:pNode;\r
anOperator:operator) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(ExpressionPrime);\r
ptrNode.TheType:=ExpressionPrime;\r
ptrNode.ExpP_ExprPrime:=ExprPrime;\r
ptrNode.ExpP_Term:=Term;\r
ptrNode.ExpP_op:=anOperator;\r
return ptrNode;\r
end MkExprPrimeNode;\r
\r
function MkTermNode(Fact,TermPrime:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Terme);\r
ptrNode.TheType:=Terme;\r
ptrNode.Ter_TermPrime:=TermPrime;\r
ptrNode.Ter_Fact:=Fact;\r
return ptrNode;\r
end MkTermNode;\r
\r
function MkTermPrimeNode(Fact,TermPrime:pNode;\r
anOperator:operator) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(TermePrime);\r
ptrNode.TheType:=TermePrime;\r
ptrNode.TerP_TermPrime:=TermPrime;\r
ptrNode.TerP_Fact:=Fact;\r
ptrNode.TerP_op:=anOperator;\r
return ptrNode;\r
end MkTermPrimeNode;\r
\r
function MkFactNode(aNode:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Facteur);\r
ptrNode.TheType:=Facteur;\r
ptrNode.Fac_Node:=aNode;\r
return ptrNode;\r
end MkFactNode;\r
\r
function MkIdNode(Val:Lexical.Lexeme) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Id);\r
ptrNode.TheType:=Id;\r
ptrNode.Id_Val:=Val;\r
return ptrNode;\r
end MkIdNode;\r
\r
function MkNbNode(Val:integer) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Nombre);\r
ptrNode.TheType:=Nombre;\r
ptrNode.Nb_Val:=Val;\r
return ptrNode;\r
end MkNbNode;\r
\r
function MkAffectNode(Id,Expr:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Affect);\r
ptrNode.TheType:=Affect;\r
ptrNode.Aff_Id:=Id;\r
ptrNode.Aff_Expr:=Expr;\r
return ptrNode;\r
end MkAffectNode;\r
\r
function MkFaireNode(id1,id2:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Faire);\r
ptrNode.TheType:=Faire;\r
ptrNode.Fai_id1:=id1;\r
ptrNode.Fai_id2:=id2;\r
return ptrNode;\r
end MkFaireNode;\r
\r
function MkRepeterNode(Expr,Instr:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Repeter);\r
ptrNode.TheType:=Repeter;\r
ptrNode.Rep_Expr:=Expr;\r
ptrNode.Rep_Instr:=Instr;\r
return ptrNode;\r
end MkRepeterNode;\r
\r
function MkSiNode(Cond,Instr,Sinon:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Si);\r
ptrNode.TheType:=Si;\r
ptrNode.Si_Cond:=Cond;\r
ptrNode.Si_Instr:=Instr;\r
ptrNode.Si_Sinon:=Sinon;\r
return ptrNode;\r
end MkSiNode;\r
\r
function MkSinonNode(Instr:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Sinon);\r
ptrNode.TheType:=Sinon;\r
ptrNode.Sin_Instr:=Instr;\r
return ptrNode;\r
end MkSinonNode;\r
\r
function MkAutempsNode(Expr,Instr:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Autemps);\r
ptrNode.TheType:=Autemps;\r
ptrNode.Aut_Expr:=Expr;\r
ptrNode.Aut_Instr:=Instr;\r
return ptrNode;\r
end MkAutempsNode;\r
\r
function MkAttendreNode(Expr:pNode) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Attendre);\r
ptrNode.TheType:=Attendre;\r
ptrNode.Att_Expr:=Expr;\r
return ptrNode;\r
end MkAttendreNode;\r
\r
function MkCondNode(Expr1,Expr2:pNode;anOpRel:op_rel) return pNode is\r
ptrNode:pNode;\r
begin\r
ptrNode:= new Node(Condition);\r
ptrNode.TheType:=Condition;\r
ptrNode.Con_Expr1:=Expr1;\r
ptrNode.Con_Expr2:=Expr2;\r
ptrNode.Con_op:=anOpRel;\r
return ptrNode;\r
end MkCondNode;\r
\r
function NbGetValue(aNbNode:pNode) return Integer is\r
begin\r
return aNbNode.Nb_Val;\r
end NbGetValue;\r
\r
function IdGetLex(aIdNode:pNode) return Lexical.Lexeme is\r
begin\r
return aIdNode.Id_Val;\r
end IdGetLex;\r
\r
function ConditionIsTrue(aCondNode:pNode) return Boolean is\r
begin\r
return aCondNode.Con_Val;\r
end ConditionIsTrue;\r
\r
procedure IdSetValue(aIdNode:pNode;aVal:Lexical.Lexeme) is\r
begin\r
aIdNode.Id_Val:=aVal;\r
end IdSetValue;\r
\r
procedure PrintId(ptr:pNode) is\r
begin\r
Text_IO.Put("Id");\r
Text_IO.Put(' ');\r
end PrintId;\r
\r
procedure PrintExpr(ptr:pNode) is\r
begin\r
Text_IO.Put("Exp_Val");\r
Text_IO.Put(' ');\r
end PrintExpr;\r
\r
procedure PrintFaire(ptr:pNode) is\r
begin\r
Text_IO.Put("-> Faire ");\r
PrintId(ptr.Fai_id1);\r
PrintId(ptr.Fai_id2);\r
Text_IO.New_Line;\r
end PrintFaire;\r
\r
procedure PrintActiver(ptr:pNode) is\r
begin\r
Text_IO.Put(" -> Activer ");\r
PrintId(ptr.Act_id1);\r
PrintId(ptr.Act_id2);\r
Text_IO.New_Line;\r
end PrintActiver;\r
\r
procedure PrintDesactiver(ptr:pNode) is\r
begin\r
Text_IO.Put(" -> Desactiver ");\r
PrintId(ptr.Des_id1);\r
PrintId(ptr.Des_id2);\r
Text_IO.New_Line;\r
end PrintDesactiver;\r
\r
procedure PrintModifier(ptr:pNode) is\r
begin\r
Text_IO.Put(" -> Modifier ");\r
PrintId(ptr.Mod_id1);\r
PrintId(ptr.Mod_id2);\r
PrintExpr(ptr.Mod_Expr);\r
Text_IO.New_Line;\r
end PrintModifier;\r
\r
procedure PrintEvoluer(ptr:pNode) is\r
begin\r
Text_IO.Put(" -> Evoluer ");\r
PrintId(ptr.Evo_id1);\r
PrintId(ptr.Evo_id2);\r
PrintExpr(ptr.Evo_Expr1);\r
PrintExpr(ptr.Evo_Expr2);\r
Text_IO.New_Line;\r
end PrintEvoluer;\r
\r
procedure PrintRepeter(ptr:pNode) is\r
begin\r
Text_IO.Put(" -------> Repeter ");\r
PrintExpr(ptr.Rep_Expr);\r
Text_IO.New_Line;\r
PrintTree(ptr.Rep_Instr);\r
Text_IO.New_Line;\r
Text_IO.Put_Line(" -------> fin Repeter ");\r
end PrintRepeter;\r
\r
procedure PrintSinon(ptr:pNode) is\r
begin\r
Text_IO.Put("--------> Sinon ");\r
PrintTree(ptr.Sin_Instr);\r
Text_IO.New_Line;\r
end PrintSinon;\r
\r
procedure PrintCond(ptr:pNode) is\r
begin\r
Text_IO.Put(boolean'image(ptr.Con_Val));\r
end PrintCond;\r
\r
procedure PrintSi(ptr:pNode) is\r
begin\r
Text_IO.Put("--------> Si ");\r
PrintCond(ptr.Si_Cond);\r
Text_IO.Put(" alors ");\r
Text_IO.New_Line;\r
PrintTree(ptr.Si_Instr);\r
if ptr.Si_Sinon/=null then\r
PrintSinon(ptr.Si_Sinon);\r
end if;\r
Text_IO.Put_Line("-------> fin Si ");\r
end PrintSi;\r
\r
procedure PrintAutemps(ptr:pNode) is\r
begin\r
Text_IO.Put("--------> Autemps ");\r
PrintExpr(ptr.Aut_Expr);\r
Text_IO.New_Line;\r
PrintTree(ptr.Aut_Instr);\r
Text_IO.New_Line;\r
Text_IO.Put_Line("-------> fin Autemps ");\r
end PrintAutemps;\r
\r
procedure PrintAttendre(ptr:pNode) is\r
begin\r
Text_IO.Put("--------> Attendre ");\r
PrintExpr(ptr.Att_Expr);\r
Text_IO.New_Line;\r
end PrintAttendre;\r
\r
procedure PrintTree(aNode:pNode) is\r
ptr:pNode;\r
begin\r
ptr:=aNode;\r
while ptr/=NULL loop\r
case ptr.TheType is\r
when faire => PrintFaire(ptr);\r
when activer => PrintActiver(ptr);\r
when desactiver => PrintDesactiver(ptr);\r
when modifier => PrintModifier(ptr);\r
when evoluer => PrintEvoluer(ptr);\r
when repeter => PrintRepeter(ptr);\r
when si => PrintSi(ptr);\r
when autemps => PrintAutemps(ptr);\r
when attendre => PrintAttendre(ptr);\r
when others => null;\r
end case;\r
ptr:=ptr.Next;\r
end loop;\r
end PrintTree;\r
\r
end Nodes;\r
package body Tic is\r
TicRate:duration:=0.1;\r
Kill : Boolean:=FALSE;\r
\r
task TicTac is\r
entry Start;\r
entry Wait;\r
end TicTac;\r
\r
task body TicTac is\r
begin\r
loop\r
accept Start;\r
delay(TicRate);\r
accept Wait;\r
exit when Kill;\r
end loop;\r
end TicTac;\r
\r
procedure StartTic is\r
begin\r
TicTac.Start;\r
end StartTic;\r
\r
procedure SetTicRate(TheRate:duration:=0.1) is\r
begin\r
TicRate:=TheRate;\r
end SetTicRate;\r
\r
procedure WaitForTic is -- bloquant pour l'appelant\r
begin\r
TicTac.Wait;\r
end WaitForTic;\r
\r
procedure ReleaseTic is\r
begin\r
Kill:=TRUE;\r
end ReleaseTic;\r
end Tic;\r
package body Bounded_Strings is\r
\r
function Power (Of_Number, N : Integer) return integer is\r
Result : Integer := 1;\r
begin\r
if N = 0 then\r
return 1;\r
else\r
for K in 1..N loop\r
Result := Result * Of_Number;\r
end loop;\r
return Result;\r
end if;\r
exception\r
when Numeric_Error => return 0;\r
end Power;\r
\r
function To_Number (The_string : in Variable_Strings;\r
In_Base : in Positive) return Integer is\r
I : Integer := The_String.The_Length;\r
Aux : Integer;\r
Result : Integer := 0;\r
begin\r
while I >= 1 loop\r
if The_String.The_Content(I) in '0'..'9' then\r
Aux := Character'Pos(The_String.The_Content(I)) - 48;\r
else\r
Aux := Character'Pos(The_String.The_Content(I)) - 55;\r
end if;\r
Result := Result + Aux * Power(In_Base, The_String.The_Length-I);\r
I := I - 1;\r
end loop;\r
return Result;\r
exception\r
when Numeric_Error => return 0;\r
end To_Number;\r
\r
\r
procedure Free (The_String : in out Variable_Strings) is\r
begin\r
The_String.The_Length := void;\r
end Free;\r
\r
procedure Append (To_The_String : in out Variable_Strings;\r
The_Char : in character) is\r
begin\r
If (To_The_String.The_Length < To_The_String.The_Content'Last) then\r
To_The_String.The_Length := To_The_String.The_Length +1;\r
To_The_String.The_Content (To_The_String.The_Length) := The_Char;\r
end if;\r
end Append;\r
\r
procedure Set (The_String : in out Variable_Strings;\r
With_String : in String) is\r
begin\r
If (With_String'Last <= The_String.The_Content'Last) then\r
The_String.The_Length := With_String'length;\r
The_String.The_Content (With_String'Range) :=\r
With_String(With_String'Range);\r
else\r
The_String.The_Length := The_String.The_Content'Length;\r
The_String.The_Content (The_String.The_Content'Range) :=\r
With_String(The_String.The_Content'Range);\r
end if;\r
end Set;\r
\r
Procedure Affect (The_String : in out Variable_Strings;\r
With_String : in Variable_Strings) is\r
begin\r
If (With_String.The_Content'Last <= The_String.The_Content'Last) then\r
The_String.The_Length := With_String.The_Length;\r
The_String.The_Content (With_String.The_Content'Range) :=\r
With_String.The_Content (With_String.The_Content'Range);\r
else\r
The_String.The_Length := The_String.The_Content'Length;\r
The_String.The_Content (The_String.The_Content'Range) :=\r
With_String.The_Content (The_String.The_Content'Range);\r
end if;\r
end Affect;\r
\r
function Length (From_The_String : in Variable_Strings) return Natural is\r
begin\r
return From_The_String.The_Length;\r
end Length;\r
\r
function Image (From_The_String : in Variable_Strings) return String is\r
begin\r
return (From_The_String.The_Content(1..From_The_String.The_Length));\r
end Image;\r
\r
function Upper_Case_Image (From_The_String : in Variable_Strings) return String is\r
Chain : String (1..From_The_String.The_Length)\r
:= Bounded_Strings.Image (From_the_String);\r
begin\r
for I in Chain'Range loop\r
if (Chain(I) > 'Z') then\r
Chain(I) := Character'Val (Character'Pos (Chain(I)) - 32);\r
end if;\r
end loop;\r
return Chain;\r
end Upper_Case_Image;\r
\r
function Is_Equal (Left, Right : in Bounded_Strings.Variable_Strings)\r
return boolean is\r
begin\r
return ((Left.The_Length = Right.The_Length)\r
and then (Left.The_Content(1..Left.The_Length)\r
= Right.The_Content(1..Right.The_Length)));\r
end Is_Equal;\r
\r
end Bounded_Strings;
with Text_Io;\r
with Bounded_Strings;\r
with Look_Ahead;\r
with Error;\r
package body Lexical is\r
\r
Current_Token : Token := L_Eof;\r
Current_Value : Lexeme;\r
The_File : Text_Io.File_Type;\r
Line_Nbr : Positive := 1;\r
Column_Nbr : Natural := 0;\r
Nbr_Length : Natural := 0;\r
\r
\r
package Keywords is\r
function Is_Keyword (The_Lexeme : Lexeme) return Boolean;\r
function Lexeme_To_Token (From : Lexeme) return Token;\r
end Keywords;\r
\r
package body Keywords is\r
\r
type P_Keyword is access String;\r
subtype Keyword_Token is Token range L_Activer .. L_Temporel;\r
type Keywords is array (Keyword_Token) of P_Keyword;\r
\r
All_Keywords : constant Keywords :=\r
(new String'("ACTIVER"), new String'("ALORS"), new String'("ATTENDRE"),\r
new String'("AUTEMPS"), new String'("AVEC"), new String'("BINAIRE"),\r
new String'("CATEGORIE"), new String'("DEBUT"),\r
new String'("DESACTIVER"), new String'("DISCRET"),\r
new String'("EFFET"), new String'("EN"), new String'("EST"),\r
new String'("EVOLUER"), new String'("EXPERIENCE"), new String'("FAIRE"),\r
new String'("FIN"), new String'("FOIS"), new String'("FUGITIF"),\r
new String'("IMPLANTATION"), new String'("JUSQUA"),\r
new String'("MATERIEL"), new String'("MOD"), new String'("MODIFIER"),\r
new String'("REPETER"), new String'("SCENE"), new String'("SI"),\r
new String'("SINON"), new String'("SPECTACLE"), new String'("TEMPOREL"));\r
\r
\r
function Is_Keyword (The_Lexeme : Lexeme) return Boolean is\r
Word : constant String := Bounded_Strings.Image (The_Lexeme);\r
begin\r
for I in Keyword_Token loop\r
if All_Keywords (I).all = Word then\r
return True;\r
end if;\r
end loop;\r
return False;\r
end Is_Keyword;\r
\r
function Lexeme_To_Token (From : Lexeme) return Token is\r
Word : constant String := Bounded_Strings.Image (From);\r
begin\r
for I in Keyword_Token loop\r
if All_Keywords (I).all = Word then\r
return I;\r
end if;\r
end loop;\r
return L_Id;\r
end Lexeme_To_Token;\r
\r
end Keywords;\r
\r
\r
package Simulated_Automaton is\r
procedure Next;\r
end Simulated_Automaton;\r
\r
package body Simulated_Automaton is\r
\r
type State is (St_Start, St_Let, St_Minus, St_Comm, St_Great, St_Less,\r
St_Hexa, St_Nbr, St_Minute, St_Hour, St_Word, St_Second,\r
St_Found);\r
\r
subtype Low_Alpha is Character range 'a' .. 'z';\r
subtype Upp_Alpha is Character range 'A' .. 'Z';\r
\r
subtype Low_Alpha_Hexa is Character range 'a' .. 'f';\r
subtype Upp_Alpha_Hexa is Character range 'A' .. 'F';\r
\r
subtype Digit is Character range '0' .. '9';\r
\r
The_Look_Ahead : Look_Ahead.Object;\r
Eol_Flag : Boolean := False;\r
\r
procedure File_Next_Char (C : in out Character) is\r
begin\r
if Eol_Flag then\r
Line_Nbr := Line_Nbr + 1;\r
Eol_Flag := False;\r
if not Look_Ahead.Is_Existing (The_Look_Ahead) then\r
Column_Nbr := 1;\r
else\r
Column_Nbr := 0;\r
end if;\r
else\r
Column_Nbr := Column_Nbr + 1;\r
end if;\r
if Look_Ahead.Is_Existing (The_Look_Ahead) then\r
Look_Ahead.Value (The_Look_Ahead, C);\r
else\r
if At_End then\r
C := Ascii.Eot;\r
else\r
if Text_Io.End_Of_Line (The_File) then\r
Text_Io.Skip_Line (The_File);\r
C := Ascii.Lf;\r
Eol_Flag := True;\r
else\r
Text_Io.Get (The_File, C);\r
case C is\r
when Low_Alpha =>\r
C := Character'Val (Character'Pos (C) - 32);\r
when others => Null;\r
end case;\r
end if;\r
end if;\r
end if;\r
exception\r
when others =>\r
Error.Handle ("lors de la lecture du fichier source !",\r
Error.Internal);\r
end File_Next_Char;\r
\r
procedure Calculate_Nbr (Hours, Minutes, Seconds, Tenths : in Natural) is\r
begin\r
Bounded_Strings.Set (Current_Value,\r
Integer'Image (Hours*3600*10 + Minutes*60*10 + Seconds*10 + Tenths));\r
exception\r
when Numeric_Error =>\r
Bounded_Strings.Set (Current_Value, Integer'Image(0));\r
end Calculate_Nbr;\r
\r
procedure Next is\r
Current_State : State;\r
Current_Char : Character;\r
Number : Integer;\r
Hours, Minutes, Seconds, Tenths : Natural;\r
begin\r
if not At_End then\r
Bounded_Strings.Free (Current_Value);\r
Hours := 0; Minutes := 0; Seconds := 0; Tenths := 0;\r
Nbr_Length := 0;\r
Current_State := St_Start;\r
loop\r
\r
File_Next_Char (Current_Char);\r
case Current_State is\r
\r
when St_Start =>\r
\r
case Current_Char is\r
\r
when Ascii.Eot =>\r
Current_Token := L_Eof;\r
Current_State := St_Found;\r
\r
when ' ' | Ascii.Lf | Ascii.Ht =>\r
null;\r
\r
when '(' =>\r
Current_Token := L_Open;\r
Current_State := St_Found;\r
\r
when ')' =>\r
Current_Token := L_Close;\r
Current_State := St_Found;\r
\r
when ',' =>\r
Current_Token := L_Comma;\r
Current_State := St_Found;\r
\r
when '.' =>\r
Current_Token := L_Point;\r
Current_State := St_Found;\r
\r
when ':' =>\r
Current_State := St_Let;\r
\r
when '+' =>\r
Current_Token := L_Plus;\r
Current_State := St_Found;\r
\r
when '-' =>\r
Current_State := St_Minus;\r
\r
when '*' =>\r
Current_Token := L_Star;\r
Current_State := St_Found;\r
\r
when '/' =>\r
Current_Token := L_Slash;\r
Current_State := St_Found;\r
\r
when '=' =>\r
Current_Token := L_Equ;\r
Current_State := St_Found;\r
\r
when '>' =>\r
Current_State := St_Great;\r
\r
when '<' =>\r
Current_State := St_Less;\r
\r
when '#' =>\r
Current_State := St_Hexa;\r
\r
when Digit =>\r
Bounded_Strings.Append\r
(Current_Value, Current_Char);\r
Current_State := St_Nbr;\r
\r
when Upp_Alpha | '_' =>\r
Bounded_Strings.Append\r
(Current_Value, Current_Char);\r
Current_State := St_Word;\r
\r
when others =>\r
Current_Token := L_Unk;\r
Current_State := St_Found;\r
end case;\r
\r
when St_Let =>\r
if Current_Char = '=' then\r
Current_Token := L_Affect;\r
Current_State := St_Found;\r
else\r
Current_Token := L_Unk;\r
Current_State := St_Found;\r
end if;\r
\r
when St_Minus =>\r
if Current_Char = '-' then\r
Current_State := St_Comm;\r
else\r
Look_Ahead.Affect (The_Look_Ahead, Current_Char);\r
Current_Token := L_Minus;\r
Current_State := St_Found;\r
end if;\r
\r
when St_Comm =>\r
case Current_Char is\r
when Ascii.Lf =>\r
Current_State := St_Start;\r
when Ascii.Eot =>\r
Current_Token := L_Eof;\r
Current_State := St_Found;\r
when others =>\r
Null;\r
end case;\r
\r
when St_Great =>\r
if Current_Char = '=' then\r
Current_Token := L_Geq;\r
Current_State := St_Found;\r
else\r
Look_Ahead.Affect (The_Look_Ahead, Current_Char);\r
Current_Token := L_Gt;\r
Current_State := St_Found;\r
end if;\r
\r
when St_Less =>\r
case Current_Char is\r
when '=' =>\r
Current_Token := L_Leq;\r
Current_State := St_Found;\r
\r
when '>' =>\r
Current_Token := L_Neq;\r
Current_State := St_Found;\r
\r
when others =>\r
Look_Ahead.Affect\r
(The_Look_Ahead, Current_Char);\r
Current_Token := L_Lt;\r
Current_State := St_Found;\r
end case;\r
\r
when St_Hexa =>\r
case Current_Char is\r
when Digit | Upp_Alpha_Hexa =>\r
Bounded_Strings.Append\r
(Current_Value, Current_Char);\r
\r
when others =>\r
Look_Ahead.Affect\r
(The_Look_Ahead, Current_Char);\r
Number := Bounded_Strings.To_Number\r
(Current_Value, 16);\r
Bounded_Strings.Free (Current_Value);\r
Bounded_Strings.Set\r
(Current_Value, Integer'Image (Number));\r
Current_Token := L_Nbr;\r
Current_State := St_Found;\r
end case;\r
\r
when St_Nbr =>\r
case Current_Char is\r
when Digit =>\r
Nbr_Length := Nbr_Length + 1;\r
Bounded_Strings.Append (Current_Value, Current_Char);\r
\r
when 'S' =>\r
Nbr_Length := Nbr_Length + 1;\r
Seconds := Lexical.Number;\r
Current_State := St_Second;\r
Bounded_Strings.Free (Current_Value);\r
\r
when 'M' =>\r
Nbr_Length := Nbr_Length + 1;\r
Current_State := St_Minute;\r
Minutes := Lexical.Number;\r
Bounded_Strings.Free (Current_Value);\r
\r
when 'H' =>\r
Nbr_Length := Nbr_Length + 1;\r
Current_State := St_Hour;\r
Hours := Lexical.Number;\r
Bounded_Strings.Free (Current_Value);\r
\r
when others =>\r
if Bounded_Strings.Length (Current_Value) /= 0 then\r
Tenths := Lexical.Number;\r
end if;\r
Calculate_Nbr (Hours, Minutes, Seconds, Tenths);\r
Look_Ahead.Affect (The_Look_Ahead, Current_Char);\r
Current_Token := L_Nbr;\r
Current_State := St_Found;\r
end case;\r
\r
when St_Second =>\r
if Current_Char in Digit then\r
Nbr_Length := Nbr_Length + 1;\r
Bounded_Strings.Append (Current_Value, Current_Char);\r
else\r
if Bounded_Strings.Length (Current_Value) /= 0 then\r
Tenths := Lexical.Number;\r
end if;\r
Calculate_Nbr (Hours, Minutes, Seconds, Tenths);\r
Look_Ahead.Affect (The_Look_Ahead, Current_Char);\r
Current_Token := L_Nbr;\r
Current_State := St_Found;\r
end if;\r
\r
when St_Minute =>\r
case Current_Char is\r
when Digit =>\r
Nbr_Length := Nbr_Length + 1;\r
Bounded_Strings.Append (Current_Value, Current_Char);\r
\r
when 'S' =>\r
Nbr_Length := Nbr_Length + 1;\r
Seconds := Lexical.Number;\r
Current_State := St_Second;\r
Bounded_Strings.Free (Current_Value);\r
\r
when others =>\r
if Bounded_Strings.Length (Current_Value) /= 0 then\r
Tenths := Lexical.Number;\r
end if;\r
Calculate_Nbr (Hours, Minutes, Seconds, Tenths);\r
Look_Ahead.Affect (The_Look_Ahead, Current_Char);\r
Current_Token := L_Nbr;\r
Current_State := St_Found;\r
end case;\r
\r
when St_Hour =>\r
case Current_Char is\r
when Digit =>\r
Nbr_Length := Nbr_Length + 1;\r
Bounded_Strings.Append (Current_Value, Current_Char);\r
\r
when 'S' =>\r
Nbr_Length := Nbr_Length + 1;\r
Current_State := St_Second;\r
Seconds := Lexical.Number;\r
Bounded_Strings.Free (Current_Value);\r
\r
when 'M' =>\r
Nbr_Length := Nbr_Length + 1;\r
Current_State := St_Minute;\r
Minutes := Lexical.Number;\r
Bounded_Strings.Free (Current_Value);\r
\r
when others =>\r
if Bounded_Strings.Length (Current_Value) /= 0 then\r
Tenths := Lexical.Number;\r
end if;\r
Calculate_Nbr(Hours, Minutes, Seconds, Tenths);\r
Look_Ahead.Affect (The_Look_Ahead, Current_Char);\r
Current_Token := L_Nbr;\r
Current_State := St_Found;\r
end case;\r
\r
when St_Word =>\r
case Current_Char is\r
when Upp_Alpha | '_' | Digit =>\r
Bounded_Strings.Append\r
(Current_Value, Current_Char);\r
\r
when others =>\r
Look_Ahead.Affect\r
(The_Look_Ahead, Current_Char);\r
Current_Token :=\r
Keywords.Lexeme_To_Token (Lexical.Value);\r
Current_State := St_Found;\r
end case;\r
\r
when St_Found =>\r
null;\r
end case;\r
if Look_Ahead.Is_Existing (The_Look_Ahead) then\r
Column_Nbr := Column_Nbr - 1;\r
end if;\r
exit when Current_State = St_Found;\r
end loop;\r
else\r
Current_Token := L_Eof;\r
end if;\r
end Next;\r
\r
end Simulated_Automaton;\r
\r
\r
procedure Open (File_Name : in String) is\r
begin\r
Text_Io.Open (The_File, Text_Io.In_File, File_Name);\r
exception\r
when Text_Io.Name_Error => -- nom de fichier incorrect\r
Error.Handle (File_Name & " est un nom de fichier incorrect !",\r
Error.Internal);\r
when others =>\r
Error.Handle ("lors de l'ouverture du fichier " & File_Name,\r
Error.Internal);\r
end Open;\r
\r
function At_End return Boolean is\r
begin\r
return Text_Io.End_Of_File (The_File);\r
exception\r
when others =>\r
Error.Handle ("lors de l'acces au fichier source !",\r
Error.Internal);\r
end At_End;\r
\r
procedure Next is\r
begin\r
Simulated_Automaton.Next;\r
end Next;\r
\r
function Get return Token is\r
begin\r
return Current_Token;\r
end Get;\r
\r
function Value return Lexeme is\r
begin\r
return Current_Value; \r
end Value;\r
\r
function Number return Integer is\r
begin\r
return Integer'Value(Bounded_Strings.Image(Current_value));\r
end Number;\r
\r
function Line_Number return Positive is\r
begin\r
return Line_Nbr;\r
end Line_Number;\r
\r
function Column_Number return Positive is\r
begin\r
case Current_Token is\r
when L_Open..L_Equ =>\r
return (Column_Nbr);\r
when L_Affect..L_Leq =>\r
return (Column_Nbr - 1);\r
when L_Nbr =>\r
return (Column_Nbr - Nbr_Length);\r
when L_Id..L_Unk =>\r
return (Column_Nbr - Bounded_Strings.Length (Current_Value) + 1);\r
when L_Eof =>\r
return 1;\r
end case;\r
end Column_Number;\r
\r
procedure Close is\r
begin\r
Text_Io.Close (The_File);\r
exception\r
when others =>\r
Error.Handle ("lors de la fermeture du fichier source !",\r
Error.Internal);\r
end Close;\r
\r
end Lexical;\r
package body Look_Ahead is
function Is_Existing (The_Look_Ahead : Object) return Boolean is
begin
return The_Look_Ahead.Existence;
end Is_Existing;
procedure Value (The_Look_Ahead : in out Object; Char : out Character) is
begin
The_Look_Ahead.Existence := False;
Char := The_Look_Ahead.Content;
end Value;
procedure Affect (The_Look_Ahead : in out Object;
With_The_Char : in Character) is
begin
The_Look_Ahead.Content := With_The_Char;
The_Look_Ahead.Existence := True;
end Affect;
end Look_Ahead;
with Text_Io;\r
with Nodes;\r
with Lexical; \r
use Lexical;\r
with Symbol;\r
use Symbol;\r
with Bounded_Strings;\r
with Error;\r
use Error;\r
package body Parser is\r
\r
\r
Procedure Parse_Corps_Scene (Parse: in out Boolean;\r
Ptr_Scene: out Nodes.pNode);\r
--prototype,declaration incomplete\r
\r
Procedure Parse_Prog_Principal (Parse: in out Boolean;\r
Ptr_Prog_Principal: out Nodes.pNode) is\r
Ptr_Scene_S: Nodes.pNode;\r
begin\r
if Lexical.Get = L_Debut then\r
Lexical.Next;\r
Parse_Corps_Scene(Parse,Ptr_Scene_S);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
Ptr_Prog_Principal:=Ptr_Scene_S;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Prog_Principal;\r
\r
Procedure Parse_Terme (Parse: in out Boolean;\r
Ptr_Term: in out Nodes.pNode);\r
--prototype,declaration incomplete\r
\r
Procedure Parse_Facteur (Parse: in out Boolean;\r
Ptr_Fact: in out Nodes.pNode);\r
--prototype,declaration incomplete\r
\r
Procedure Parse_Expression(Parse: in out Boolean;\r
Ptr_Expr:in out Nodes.pNode) is\r
Use Nodes;\r
Parse_Ter : Boolean:=True;\r
Ptr_TermL_S,Ptr_TermR_S,pAux:Nodes.pNode;\r
begin\r
Parse_Terme(Parse,Ptr_TermL_S);\r
if Parse then\r
Ptr_Expr:=Nodes.MkExprNode(Ptr_TermL_S,null);\r
pAux:=Ptr_Expr;\r
if Lexical.Get = L_Plus or else\r
Lexical.Get = L_Minus then\r
\r
while Lexical.Get = L_Plus or else\r
Lexical.Get = L_Minus loop\r
\r
case Lexical.Get is\r
when L_Plus =>\r
Lexical.Next;\r
Parse_Terme(Parse_Ter,Ptr_TermR_S);\r
if Parse_Ter then\r
if pAux.TheType=Expression then\r
pAux.Exp_ExprPrime:=\r
Nodes.MkExprPrimeNode(Ptr_TermR_S,null,Add);\r
else\r
pAux.ExpP_ExprPrime:=\r
Nodes.MkExprPrimeNode(Ptr_TermR_S,null,Add);\r
end if;\r
end if;\r
when L_Minus =>\r
Lexical.Next;\r
Parse_Terme(Parse_Ter,Ptr_TermR_S);\r
if Parse_Ter then\r
if pAux.TheType=Expression then\r
pAux.Exp_ExprPrime:=\r
Nodes.MkExprPrimeNode(Ptr_TermR_S,null,Sub);\r
else\r
pAux.ExpP_ExprPrime:=\r
Nodes.MkExprPrimeNode(Ptr_TermR_S,null,Sub);\r
end if;\r
end if;\r
when others =>\r
Parse:=False;\r
end case;\r
if pAux.TheType =Expression then\r
pAux:=pAux.Exp_ExprPrime; -- pour chainage des operations\r
else\r
pAux:=pAux.ExpP_ExprPrime;\r
end if;\r
exit when not Parse_Ter;\r
end loop;\r
end if;\r
Parse:=Parse_Ter;\r
end if;\r
end Parse_Expression;\r
\r
Procedure Parse_Terme (Parse: in out Boolean;\r
Ptr_Term: in out Nodes.pNode) is\r
Use Nodes;\r
Parse_Term : Boolean:=True;\r
Ptr_FactL_S,Ptr_FactR_S,pAux:Nodes.pNode;\r
begin\r
Parse_Facteur(Parse,Ptr_FactL_S);\r
if Parse then\r
Ptr_Term:=Nodes.MkTermNode(Ptr_FactL_S,null);\r
pAux:=Ptr_Term;\r
if Lexical.Get = L_Star or else\r
Lexical.Get = L_Slash or else\r
Lexical.Get = L_Mod then\r
\r
while Lexical.Get = L_Star or else\r
Lexical.Get = L_Slash or else\r
Lexical.Get = L_Mod loop\r
\r
case Lexical.Get is\r
when L_Star =>\r
Lexical.Next;\r
Parse_Facteur(Parse_Term,Ptr_FactR_S);\r
if Parse_Term then\r
if pAux.TheType=Terme then\r
pAux.Ter_TermPrime:=\r
Nodes.MkTermPrimeNode(Ptr_FactR_S,null,Mul);\r
else\r
pAux.TerP_TermPrime:=\r
Nodes.MkTermPrimeNode(Ptr_FactR_S,null,Mul);\r
end if;\r
end if;\r
when L_Slash =>\r
Lexical.Next;\r
Parse_Facteur(Parse_Term,Ptr_FactR_S);\r
if Parse_Term then\r
if pAux.TheType=Terme then\r
pAux.Ter_TermPrime:=\r
Nodes.MkTermPrimeNode(Ptr_FactR_S,null,Div);\r
else\r
pAux.TerP_TermPrime:=\r
Nodes.MkTermPrimeNode(Ptr_FactR_S,null,Div);\r
end if;\r
end if;\r
when L_Mod =>\r
Lexical.Next;\r
Parse_Facteur(Parse_Term,Ptr_FactR_S);\r
if Parse_Term then\r
if pAux.TheType=Terme then\r
pAux.Ter_TermPrime:=\r
Nodes.MkTermPrimeNode(Ptr_FactR_S,null,Modulo);\r
else\r
pAux.TerP_TermPrime:=\r
Nodes.MkTermPrimeNode(Ptr_FactR_S,null,Modulo);\r
end if;\r
end if;\r
when others =>\r
Parse_Term:=False;\r
end case;\r
if pAux.TheType=Terme then\r
pAux:=pAux.Ter_TermPrime;\r
else\r
pAux:=pAux.terP_TermPrime;\r
end if;\r
exit when not Parse_Term;\r
end loop;\r
end if;\r
Parse:=Parse_Term;\r
end if;\r
end Parse_Terme;\r
\r
Procedure Parse_Facteur (Parse: in out Boolean;\r
Ptr_Fact: in out Nodes.pNode) is\r
Use Nodes;\r
Ptr_Fact_S: Nodes.pNode;\r
begin\r
case Lexical.Get is\r
when L_Open =>\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Fact_S);\r
if Parse then\r
if Lexical.Get = L_Close then\r
Ptr_Fact:=MkFactNode(Ptr_Fact_S);\r
Lexical.Next;\r
Parse:=True;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
when L_Id =>\r
Ptr_Fact:=MkFactNode(Nodes.MkIdNode(Lexical.Value));\r
Lexical.Next;\r
Parse:=True;\r
when L_Nbr =>\r
Ptr_Fact:=MkFactNode(Nodes.MkNbNode(Lexical.Number));\r
Lexical.Next;\r
Parse:=True;\r
when others =>\r
Parse:=False;\r
end case;\r
end Parse_Facteur;\r
\r
Procedure Parse_Evoluer (Parse: in out Boolean;\r
Ptr_Id1,Ptr_Id2: out Nodes.pNode;\r
Ptr_Expr1,Ptr_Expr2: out Nodes.pNode) is\r
Id1,Id2: Lexical.Lexeme;\r
Ptr_Expr1_S,Ptr_Expr2_S: Nodes.pNode;\r
begin\r
if Lexical.Get = L_Id then\r
Id1:=Lexical.Value;\r
Lexical.Next;\r
if Lexical.Get = L_Point then\r
Lexical.Next;\r
if Lexical.Get = L_Id then\r
Id2:=Lexical.Value;\r
Lexical.Next;\r
if Lexical.Get = L_Jusqua then\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr1_S);\r
if Parse then\r
if Lexical.Get = L_En then\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr2_S);\r
if Parse then\r
Ptr_Id1:=Nodes.MkIdNode(Id1);\r
Ptr_Id2:=Nodes.MkIdNode(Id2);\r
Ptr_Expr1:=Ptr_Expr1_S;\r
Ptr_Expr2:=Ptr_Expr2_S;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Evoluer;\r
\r
Procedure Parse_Modifier (Parse: in out Boolean;\r
Ptr_Id1,Ptr_Id2: out Nodes.pNode;\r
Ptr_Expr: out Nodes.pNode) is\r
Id1,Id2:Lexical.Lexeme;\r
Ptr_Expr_S: Nodes.pNode;\r
begin\r
if Lexical.Get = L_Id then\r
Id1:=Lexical.Value;\r
Lexical.Next;\r
if Lexical.Get = L_Point then\r
Lexical.Next;\r
if Lexical.Get = L_Id then\r
Id2:=Lexical.Value;\r
Lexical.Next;\r
if Lexical.Get = L_Avec then\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr_S);\r
if Parse then\r
Ptr_Id1:=Nodes.MkIdNode(Id1);\r
Ptr_Id2:=Nodes.MkIdNode(Id2);\r
Ptr_Expr:=Ptr_Expr_S;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Modifier;\r
\r
Procedure Parse_Desactiver (Parse: in out Boolean;\r
Ptr_Id1,Ptr_Id2: out Nodes.pNode ) is\r
Id1,Id2:Lexical.Lexeme;\r
begin\r
if Lexical.Get = L_Id then\r
Id1:=Lexical.Value;\r
Lexical.Next;\r
if Lexical.Get = L_Point then\r
Lexical.Next;\r
if Lexical.Get = L_Id then\r
Id2:=Lexical.Value;\r
Lexical.Next;\r
Parse:=True;\r
Ptr_Id1:=Nodes.MkIdNode(Id1);\r
Ptr_Id2:=Nodes.MkIdNode(Id2);\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Desactiver;\r
\r
Procedure Parse_Activer (Parse : in out Boolean;\r
Ptr_Id1,Ptr_Id2: out Nodes.pNode ) is\r
Id1,Id2:Lexical.Lexeme;\r
begin\r
if Lexical.Get = L_Id then\r
Id1:=Lexical.Value;\r
Lexical.Next;\r
if Lexical.Get = L_Point then\r
Lexical.Next;\r
if Lexical.Get = L_Id then\r
Id2:=Lexical.Value;\r
Lexical.Next;\r
Parse:=True;\r
Ptr_Id1:=Nodes.MkIdNode(Id1);\r
Ptr_Id2:=Nodes.MkIdNode(Id2);\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Activer;\r
\r
Procedure Parse_Action_Predef (Parse: in out Boolean;\r
Ptr_Action_Predef: in out Nodes.pNode) is\r
Ptr_Id1_S: Nodes.pNode;\r
Ptr_Id2_S: Nodes.pNode;\r
Ptr_Expr1_S,Ptr_Expr2_S: Nodes.pNode;\r
begin\r
case Lexical.Get is\r
when L_Activer =>\r
Lexical.Next;\r
Parse_Activer(Parse,Ptr_Id1_S,Ptr_Id2_S);\r
if Parse then\r
Ptr_Action_Predef:=Nodes.MkActiverNode(Ptr_Id1_S,\r
Ptr_Id2_S);\r
end if;\r
when L_Desactiver =>\r
Lexical.Next;\r
Parse_Desactiver(Parse,Ptr_Id1_S,Ptr_Id2_S);\r
if Parse then\r
Ptr_Action_Predef:=Nodes.MkDesactiverNode(Ptr_Id1_S,\r
Ptr_Id2_S);\r
end if;\r
when L_Modifier =>\r
Lexical.Next;\r
Parse_Modifier(Parse,Ptr_Id1_S,Ptr_Id2_S,Ptr_Expr1_S);\r
if Parse then\r
Ptr_Action_Predef:=Nodes.MkModifierNode(Ptr_Id1_S,\r
Ptr_Id2_S,\r
Ptr_Expr1_S);\r
end if;\r
when L_Evoluer =>\r
Lexical.Next;\r
Parse_Evoluer(Parse,Ptr_Id1_S,Ptr_Id2_S,\r
Ptr_Expr1_S,Ptr_Expr2_S);\r
if Parse then\r
Ptr_Action_Predef:=Nodes.MkEvoluerNode(Ptr_Id1_S,\r
Ptr_Id2_S,\r
Ptr_Expr1_S,\r
Ptr_Expr2_S);\r
end if;\r
when others =>\r
Parse:=False;\r
end case;\r
end Parse_Action_Predef;\r
\r
Procedure Parse_Faire (Parse : in out Boolean;\r
Ptr_Id1: out Nodes.pNode;\r
Ptr_Id2: in out Nodes.pNode);\r
-- prototype, declaration incomplete\r
\r
Procedure Parse_Corps_Effet (Parse: in out Boolean;\r
Ptr_Effet: out Nodes.pNode) is\r
Use Nodes;\r
Parse_Corps_Effet : Boolean:=False;\r
Ptr_Action_Predef_S: Nodes.pNode;\r
Ptr_Id1_S,Ptr_Id2_S: Nodes.pNode;\r
Ptr_Deb_Code_Effet: Nodes.pNode:=new Node(None);\r
Ptr_Code_Effet: Nodes.pNode;\r
begin\r
Ptr_Code_Effet:=Ptr_Deb_Code_Effet;\r
while Lexical.Get = L_Activer or else\r
Lexical.Get = L_Desactiver or else\r
Lexical.Get = L_Modifier or else\r
Lexical.Get = L_Evoluer or else\r
Lexical.Get = L_Faire loop\r
\r
\r
case Lexical.Get is\r
\r
when L_Activer | L_Desactiver |\r
L_Modifier | L_Evoluer =>\r
Parse_Action_Predef(Parse_Corps_Effet,\r
Ptr_Action_Predef_S);\r
if Parse_Corps_Effet then\r
Ptr_Code_Effet.Next:=Ptr_Action_Predef_S;\r
Ptr_Code_Effet:=Ptr_Code_Effet.Next;\r
else\r
exit;\r
end if;\r
when L_Faire =>\r
Lexical.Next;\r
If Lexical.Get = L_Id and then\r
Symbol.Get_Type(Lexical.Value) = Symbol.T_effect then\r
Parse_Faire(Parse_Corps_Effet,Ptr_Id1_S,Ptr_Id2_S);\r
if Parse_Corps_Effet then\r
Ptr_Code_Effet.Next:=Nodes.MkFaireNode\r
(Ptr_Id1_S,Ptr_Id2_S);\r
Ptr_Code_Effet:=Ptr_Code_Effet.Next;\r
end if;\r
end if;\r
when others => Parse:=False;\r
end case;\r
end loop;\r
Parse:=Parse_Corps_Effet;\r
if Parse then\r
Ptr_Effet:=Ptr_Deb_Code_Effet.Next;\r
end if;\r
end Parse_Corps_Effet;\r
\r
Procedure Parse_Liste_Param (Parse : in out Boolean) is\r
Parse_Liste_Param : Boolean:=True;\r
begin \r
if Lexical.Get = L_Id then\r
Symbol.Add(Lexical.Value,Argument);\r
Lexical.Next;\r
while Lexical.Get = L_Comma loop\r
Lexical.Next;\r
if Lexical.Get = L_Id then\r
Symbol.Add(Lexical.Value,Argument);\r
Lexical.Next;\r
Parse_Liste_Param:=True;\r
else\r
Parse_Liste_Param:=False;\r
exit;\r
end if;\r
end loop;\r
Parse:=Parse_Liste_Param;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Liste_Param;\r
\r
Procedure Parse_Bloc_Param (Parse: in out Boolean) is\r
begin \r
if Lexical.Get = L_Open then\r
Lexical.Next;\r
Parse_Liste_Param(Parse);\r
if Parse then\r
if Lexical.Get = L_Close then\r
Lexical.Next;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=True; -- autorise aucun "param" declare\r
end if;\r
end Parse_Bloc_Param;\r
\r
Procedure Parse_Effet(Parse: in out Boolean) is\r
Ptr_Effet_S:Nodes.pNode;\r
Id:Lexical.Lexeme;\r
begin \r
if Lexical.Get = L_Id then\r
Id:=Lexical.Value;\r
Symbol.Add(Id,Effect);\r
Symbol.New_Table(Local_Table_Size);\r
Lexical.Next;\r
Parse_Bloc_Param(Parse);\r
if Parse then\r
if Lexical.Get = L_Est then\r
Lexical.Next;\r
Parse_Corps_Effet(Parse,Ptr_Effet_S);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Effet then\r
Lexical.Next;\r
Symbol.Set_Code(Id,Ptr_Effet_S);\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
Symbol.Release_Table;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Effet;\r
\r
Procedure Parse_Liste_Arg (Parse : in out Boolean;\r
Ptr_Liste_Arg: in out Nodes.pNode) is\r
Use Nodes;\r
Parse_Liste_Arg : Boolean:=True;\r
Ptr_Aux:Nodes.pNode;\r
begin\r
if Lexical.Get = L_Id then\r
Ptr_Aux:=Nodes.MkIdNode(Lexical.Value);\r
Ptr_Liste_Arg:=Ptr_Aux;\r
Lexical.Next;\r
while Lexical.Get = L_Comma loop\r
Lexical.Next;\r
if Lexical.Get = L_Id then\r
Ptr_Aux.Next:=Nodes.MkIdNode(Lexical.Value);\r
Lexical.Next;\r
Parse_Liste_Arg:=True;\r
Ptr_Aux:=Ptr_Aux.Next;\r
else\r
Parse_Liste_Arg:=False;\r
exit;\r
end if;\r
end loop;\r
Parse:=Parse_Liste_Arg;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Liste_Arg;\r
\r
Procedure Parse_Bloc_Arg (Parse: in out Boolean;\r
Ptr_Liste_Arg: in out Nodes.pNode) is\r
Use nodes;\r
begin\r
if Lexical.Get = L_Open then\r
Lexical.Next;\r
Parse_Liste_Arg(Parse,Ptr_Liste_Arg);\r
if Parse then\r
if Lexical.Get = L_Close then\r
Lexical.Next;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=True; -- autorise aucun "arg" declare\r
end if;\r
end Parse_Bloc_Arg;\r
\r
\r
Procedure Parse_Faire (Parse : in out Boolean;\r
Ptr_Id1: out Nodes.pNode;\r
Ptr_Id2: in out Nodes.pNode) is\r
Use Nodes;\r
Id1:Lexical.Lexeme;\r
begin\r
if Lexical.Get = L_Id then\r
Id1:=Lexical.Value;\r
Lexical.Next;\r
Parse_Bloc_Arg(Parse,Ptr_Id2);\r
if Parse then\r
Ptr_Id1:=Nodes.MkIdNode(Id1);\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Faire;\r
\r
Procedure Parse_Repeter (Parse: in out Boolean;\r
Ptr_Expr: out Nodes.pNode;\r
Ptr_Scene: out Nodes.pNode) is\r
Ptr_Expr_S: Nodes.pNode;\r
Ptr_Scene_S: Nodes.pNode;\r
begin\r
Parse_Expression(Parse,Ptr_Expr_S);\r
if Parse then\r
if Lexical.Get = L_Fois then\r
Lexical.Next;\r
Parse_Corps_Scene(Parse,Ptr_Scene_S);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Repeter then\r
Lexical.Next;\r
Ptr_Expr:=Ptr_Expr_S;\r
Ptr_Scene:=Ptr_Scene_S;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
end Parse_Repeter;\r
\r
Procedure Parse_Sinon (Parse: in out Boolean;\r
Ptr_Sinon: out Nodes.pNode) is\r
Ptr_Scene_S: Nodes.pNode;\r
begin \r
if Lexical.Get = L_Sinon then\r
Lexical.Next;\r
if Lexical.Get = L_Faire then\r
Lexical.Next;\r
Parse_Corps_Scene(Parse,Ptr_Scene_S);\r
if Parse then\r
Ptr_Sinon:=Nodes.MkSinonNode(Ptr_Scene_S);\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
end Parse_Sinon;\r
\r
Procedure Parse_Suite_Condition (Parse: in out Boolean;\r
Ptr_Expr: in out Nodes.pNode;\r
Op: out Nodes.Op_Rel) is\r
Use Nodes;\r
begin \r
case Lexical.Get is\r
when L_Equ =>\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr);\r
Op:=Eq;\r
when L_Neq =>\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr);\r
Op:=Diff;\r
when L_Gt =>\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr);\r
Op:=Sup;\r
when L_Lt =>\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr);\r
Op:=Inf;\r
when L_Geq =>\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr);\r
Op:=Sup_Eq;\r
when L_Leq =>\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr);\r
Op:=Inf_Eq;\r
when L_Alors =>\r
Op:= Op_Rel'(None);\r
when others =>\r
Parse:=False;\r
end case;\r
end Parse_Suite_Condition;\r
\r
Procedure Parse_Condition (Parse: in out Boolean;\r
Ptr_Cond: out Nodes.pNode) is\r
Ptr_Expr1_S: Nodes.pNode;\r
Ptr_Expr2_S: Nodes.pNode;\r
Op_S: Nodes.Op_Rel;\r
begin\r
Parse_Expression(Parse,Ptr_Expr1_S);\r
if Parse then\r
Parse_Suite_Condition(Parse,Ptr_Expr2_S,Op_S);\r
if Parse then\r
Ptr_Cond:=Nodes.MkCondNode(Ptr_Expr1_S,Ptr_Expr2_S,Op_S);\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Condition;\r
\r
Procedure Parse_Si (Parse: in out Boolean;\r
Ptr_Cond: out Nodes.pNode;\r
Ptr_Scene:out Nodes.pNode;\r
Ptr_Sinon: in out Nodes.pNode) is\r
begin\r
Parse_Condition(Parse,Ptr_Cond);\r
if Parse then\r
if Lexical.Get = L_Alors then\r
Lexical.Next;\r
if Lexical.Get = L_Faire then\r
Lexical.Next;\r
Parse_Corps_Scene(Parse,Ptr_Scene);\r
if Parse then\r
Parse_Sinon(Parse,Ptr_Sinon);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Si then\r
Lexical.Next;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
end Parse_Si;\r
\r
Procedure Parse_Autemps (Parse: in out Boolean;\r
Ptr_Expr: out Nodes.pNode;\r
Ptr_Scene: out Nodes.pNode) is\r
Ptr_Expr_S: Nodes.pNode;\r
Ptr_Scene_S: Nodes.pNode;\r
begin\r
Parse_Expression(Parse,Ptr_Expr_S);\r
if Parse then\r
if Lexical.Get = L_Faire then\r
Lexical.Next;\r
Parse_Corps_Scene(Parse,Ptr_Scene_S);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Autemps then\r
Lexical.Next;\r
Ptr_Expr:=Ptr_Expr_S;\r
Ptr_Scene:= Ptr_Scene_S;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
end Parse_Autemps;\r
\r
\r
Procedure Parse_Attendre (Parse: in out Boolean;\r
Ptr_Expr: out Nodes.pNode) is\r
Ptr_Expr_S: Nodes.pNode;\r
begin\r
Parse_Expression(Parse,Ptr_Expr_S);\r
if Parse then\r
Ptr_Expr:=Ptr_Expr_S;\r
end if;\r
end Parse_Attendre;\r
\r
Procedure Parse_Affect (Parse: in out Boolean;\r
Ptr_Expr: out Nodes.pNode) is\r
Ptr_Expr_S: Nodes.pNode;\r
begin\r
if Lexical.Get = L_Affect then\r
Lexical.Next;\r
Parse_Expression(Parse,Ptr_Expr_S);\r
if Parse then\r
Ptr_Expr:=Ptr_Expr_S;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Affect;\r
\r
Procedure Parse_Corps_Scene (Parse: in out Boolean;\r
Ptr_Scene: out Nodes.pNode) is\r
Use Nodes;\r
Parse_Corps_Scene : Boolean:=False;\r
Ptr_Action_Predef_S: Nodes.pNode;\r
Id1: Lexical.Lexeme;\r
Ptr_Id1_S,Ptr_Id2_S: Nodes.pNode;\r
Ptr_Expr1_S,Expr2_S: Nodes.pNode;\r
Ptr_Cond_S,Ptr_Sinon_S: Nodes.pNode;\r
Ptr_Scene_S: Nodes.pNode;\r
Ptr_Deb_Code_Scene: Nodes.pNode:=new Node(None);\r
Ptr_Code_Scene: Nodes.pNode;\r
begin\r
Ptr_Code_Scene:=Ptr_Deb_Code_Scene;\r
while Lexical.Get = L_Activer or else\r
Lexical.Get = L_Desactiver or else\r
Lexical.Get = L_Modifier or else\r
Lexical.Get = L_Faire or else\r
Lexical.Get = L_Evoluer or else\r
Lexical.Get = L_Id or else\r
Lexical.Get = L_Repeter or else\r
Lexical.Get = L_Si or else\r
Lexical.Get = L_Autemps or else\r
Lexical.Get = L_Attendre loop\r
\r
\r
case Lexical.Get is\r
when L_Activer | L_Desactiver |\r
L_Modifier | L_Evoluer =>\r
Parse_Action_Predef(Parse_Corps_Scene,\r
Ptr_Action_Predef_S);\r
if Parse_Corps_Scene then\r
Ptr_Code_Scene.Next:=Ptr_Action_Predef_S;\r
Ptr_Code_Scene:=Ptr_Code_Scene.Next;\r
end if;\r
when L_Id =>\r
Id1:=Lexical.Value;\r
Symbol.Add(Id1,Variable);\r
Lexical.Next;\r
Parse_Affect(Parse_Corps_Scene,Ptr_Expr1_S);\r
if Parse_Corps_Scene then\r
Ptr_Id1_S:=Nodes.MkIdNode(Id1);\r
Ptr_Code_Scene.Next:=Nodes.MkAffectNode\r
(Ptr_Id1_S,Ptr_Expr1_S);\r
Ptr_Code_Scene:=Ptr_Code_Scene.Next;\r
end if;\r
when L_Faire =>\r
Lexical.Next;\r
Parse_Faire(Parse_Corps_Scene,Ptr_Id1_S,Ptr_Id2_S);\r
if Parse_Corps_Scene then\r
Ptr_Code_Scene.Next:=Nodes.MkFaireNode\r
(Ptr_Id1_S,Ptr_Id2_S);\r
Ptr_Code_Scene:=Ptr_Code_Scene.Next;\r
end if;\r
when L_Repeter =>\r
Lexical.Next;\r
Parse_Repeter(Parse_Corps_Scene,Ptr_Expr1_S,\r
Ptr_Scene_S);\r
if Parse_Corps_Scene then\r
Ptr_Code_Scene.Next:=Nodes.MkRepeterNode\r
(Ptr_Expr1_S,Ptr_Scene_S);\r
Ptr_Code_Scene:=Ptr_Code_Scene.Next;\r
end if;\r
when L_Si =>\r
Lexical.Next;\r
Parse_Si(Parse_Corps_Scene,Ptr_Cond_S,Ptr_Scene_S,\r
Ptr_Sinon_S);\r
if Parse_Corps_Scene then\r
Ptr_Code_Scene.Next:=Nodes.MkSiNode\r
(Ptr_Cond_S,Ptr_Scene_S,\r
Ptr_Sinon_S);\r
Ptr_Code_Scene:=Ptr_Code_Scene.Next;\r
end if;\r
when L_Autemps =>\r
Lexical.Next;\r
Parse_Autemps(Parse_Corps_Scene,Ptr_Expr1_S,\r
Ptr_Scene_S);\r
if Parse_Corps_Scene then\r
Ptr_Code_Scene.Next:=Nodes.MkAutempsNode\r
(Ptr_Expr1_S,Ptr_Scene_S);\r
Ptr_Code_Scene:=Ptr_Code_Scene.Next;\r
end if;\r
when L_Attendre =>\r
Lexical.Next;\r
Parse_Attendre(Parse_Corps_Scene,Ptr_Expr1_S);\r
if Parse_Corps_Scene then\r
Ptr_Code_Scene.Next:=Nodes.MkAttendreNode\r
(Ptr_Expr1_S);\r
Ptr_Code_Scene:=Ptr_Code_Scene.Next;\r
end if;\r
when others =>\r
Parse_Corps_Scene:=False;\r
end case;\r
exit when not Parse_Corps_Scene;\r
end loop;\r
Parse:=Parse_Corps_Scene;\r
if Parse then\r
Ptr_Scene:=Ptr_Deb_Code_Scene.Next;\r
end if;\r
end Parse_Corps_Scene;\r
\r
Procedure Parse_Scene(Parse: in out Boolean) is\r
Ptr_Scene_S: Nodes.pNode;\r
Id:Lexical.Lexeme;\r
begin\r
if Lexical.Get = L_Id then\r
Id:=Lexical.Value;\r
Symbol.Add(Id,Scene);\r
Symbol.New_Table(Local_Table_Size);\r
Lexical.Next;\r
Parse_Bloc_Param(Parse);\r
if Parse then\r
if Lexical.Get = L_Est then\r
Lexical.Next;\r
Parse_Corps_Scene(Parse,Ptr_Scene_S);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Scene then\r
Lexical.Next;\r
Symbol.Set_Code(Id,Ptr_Scene_S);\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
Symbol.Release_Table;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Scene;\r
\r
Procedure Parse_Corps_Experience (Parse: in out Boolean) is\r
Use Nodes;\r
Parse_Corps_Experience : Boolean:=False;\r
begin\r
while Lexical.Get = L_Effet or else\r
Lexical.Get = L_Scene loop\r
\r
case Lexical.Get is\r
when L_Effet =>\r
Lexical.Next;\r
Parse_Effet(Parse_Corps_Experience);\r
when L_Scene =>\r
Lexical.Next;\r
Parse_Scene(Parse_Corps_Experience);\r
when others =>\r
Parse_Corps_Experience := False;\r
end case;\r
exit when not Parse_Corps_Experience;\r
end loop; \r
Parse:=Parse_Corps_Experience;\r
end Parse_Corps_Experience;\r
\r
Procedure Parse_Bloc_Experience (Parse: in out Boolean) is\r
begin\r
if Lexical.Get = L_Experience then\r
Lexical.Next;\r
if Lexical.Get = L_Est then\r
Lexical.Next;\r
Parse_Corps_Experience(Parse);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Experience then\r
Lexical.Next;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
end Parse_Bloc_Experience;\r
\r
Procedure Parse_Corps_Implantation (Parse: in out Boolean) is\r
Parse_Corps_Implantation : Boolean:=False;\r
Id1 : Lexical.Lexeme;\r
begin\r
while Lexical.Get = L_Id loop\r
Id1 := Lexical.Value;\r
Symbol.Add(Id1,Station);\r
Lexical.Next;\r
if Lexical.Get = L_Est then\r
Lexical.Next;\r
if Lexical.Get = L_Id then\r
Symbol.Set_Type(Id1, Lexical.Value);\r
Lexical.Next;\r
if Lexical.Get = L_En then\r
Lexical.Next;\r
if Lexical.Get = L_Nbr then\r
Symbol.Set_Value(Id1, Lexical.Number);\r
Lexical.Next;\r
Parse_Corps_Implantation:=True;\r
else\r
Parse_Corps_Implantation:=False;\r
exit;\r
end if;\r
else\r
Parse_Corps_Implantation:=False;\r
exit;\r
end if;\r
else\r
Parse_Corps_Implantation:= False;\r
exit;\r
end if;\r
else\r
Parse_Corps_Implantation:=False;\r
exit;\r
end if;\r
end loop;\r
Parse:=Parse_Corps_Implantation;\r
end Parse_Corps_Implantation;\r
\r
Procedure Parse_Bloc_Implantation (Parse: in out Boolean) is\r
begin\r
if Lexical.Get = L_Implantation then\r
Lexical.Next;\r
if Lexical.Get = L_Est then\r
Lexical.Next;\r
Parse_Corps_Implantation(Parse);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Implantation then\r
Lexical.Next;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
else\r
Parse:=False;\r
end if;\r
end Parse_Bloc_Implantation;\r
\r
Procedure Parse_Type(Parse:in out Boolean) is\r
begin\r
case Lexical.Get is\r
when L_Binaire =>\r
Lexical.Next;\r
Parse:=True;\r
when L_Temporel =>\r
Lexical.Next;\r
Parse:=True;\r
when L_Fugitif =>\r
Lexical.Next;\r
Parse:=True;\r
when L_Discret =>\r
Lexical.Next;\r
Parse:=True;\r
when others =>\r
Parse:=False;\r
end case;\r
end Parse_Type;\r
\r
Procedure Parse_Liste_D_Acteurs_Types(Parse:in out Boolean) is\r
Parse_Liste_D_Acteurs_Types : Boolean:=False;\r
begin\r
Symbol.New_Table(Actor_Table_Size);\r
while Lexical.Get = L_Id loop\r
Symbol.Add(Lexical.Value,Actor);\r
Lexical.Next;\r
Parse_Type(Parse_Liste_D_Acteurs_Types);\r
if Not Parse_Liste_D_Acteurs_Types then\r
exit;\r
end if;\r
end loop;\r
Symbol.Release_Table;\r
Parse:=Parse_Liste_D_Acteurs_Types;\r
end Parse_Liste_D_Acteurs_Types;\r
\r
Procedure Parse_Corps_Materiel (Parse:in out Boolean) is\r
Parse_Corps_Materiel : Boolean:=False;\r
begin \r
while Lexical.Get = L_Categorie loop\r
Lexical.Next;\r
if Lexical.Get = L_Id then\r
Symbol.Add(Lexical.Value,Category);\r
Lexical.Next;\r
if Lexical.Get = L_Est then\r
Lexical.Next;\r
Parse_Liste_D_Acteurs_Types(Parse_Corps_Materiel);\r
if Parse_Corps_Materiel then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Categorie then\r
Lexical.Next;\r
Parse_Corps_Materiel:=True;\r
else\r
Error.Handle(" [Categorie] attendu",Corps_Materiel);\r
exit;\r
end if;\r
else\r
Error.Handle(" [Fin] attendu",Corps_Materiel);\r
exit;\r
end if;\r
else\r
exit;\r
end if;\r
else\r
Error.Handle(" [Est] attendu",Corps_Materiel);\r
exit;\r
end if;\r
else\r
Error.Handle(" [Identificateur] attendu",Corps_Materiel);\r
exit;\r
end if;\r
end loop;\r
if Parse_Corps_Materiel then\r
Parse:=Parse_Corps_Materiel;\r
else\r
Error.Handle(" [Categorie] attendu",Corps_Materiel);\r
end if;\r
end Parse_Corps_Materiel;\r
\r
Procedure Parse_Bloc_Materiel(Parse:in out Boolean) is\r
begin \r
if Lexical.Get = L_Materiel then\r
Lexical.Next;\r
if Lexical.Get = L_Est then\r
Lexical.Next;\r
Parse_Corps_Materiel(Parse);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Materiel then\r
Lexical.Next;\r
else\r
Error.Handle(" [Materiel] attendu",Bloc_Materiel);\r
end if;\r
else\r
Error.Handle(" [Fin] attendu",Bloc_Materiel);\r
end if;\r
end if;\r
else\r
Error.Handle(" [Est] attendu",Bloc_Materiel);\r
end if;\r
else\r
Error.Handle(" [Materiel] attendu",Bloc_Materiel);\r
end if;\r
end Parse_Bloc_Materiel;\r
\r
Procedure Parse_Corps_Spectacle (Parse: in out Boolean;\r
Ptr_Corps_Spectacle: out Nodes.pNode) is\r
Ptr_Prog_Principal_S: Nodes.pNode;\r
begin\r
Parse_Bloc_Materiel(Parse);\r
if Parse then\r
Parse_Bloc_Implantation(Parse);\r
if Parse then\r
Parse_Bloc_Experience(Parse);\r
if Parse then\r
Parse_Prog_Principal(Parse,Ptr_Prog_Principal_S);\r
if Parse then\r
Ptr_Corps_Spectacle:=Ptr_Prog_Principal_S;\r
end if;\r
end if;\r
end if;\r
end if;\r
end Parse_Corps_Spectacle;\r
\r
Procedure Parse_Show (Parse: in out Boolean;\r
Ptr_Show: out Nodes.pNode) is\r
Ptr_Spectacle_S: Nodes.pNode;\r
begin\r
if Lexical.Get = L_Spectacle then\r
Lexical.Next;\r
if Lexical.Get = L_Est then\r
Lexical.Next;\r
Symbol.New_Table(Global_Table_Size);\r
Parse_Corps_Spectacle(Parse,Ptr_Spectacle_S);\r
if Parse then\r
if Lexical.Get = L_Fin then\r
Lexical.Next;\r
if Lexical.Get = L_Spectacle then\r
Lexical.Next;\r
Parse:=Lexical.Get = L_Eof;\r
if Parse then\r
Ptr_Show:=Ptr_Spectacle_S;\r
end if;\r
else\r
Error.Handle(" [Spectacle] attendu",Show);\r
end if;\r
else\r
Error.Handle(" [Fin] attendu",Show);\r
end if;\r
end if;\r
Symbol.Release_Table;\r
else\r
Error.Handle(" [Est] attendu",Show);\r
end if;\r
else\r
Error.Handle(" [Spectacle] attendu",Show);\r
end if;\r
end Parse_Show;\r
\r
Procedure Parse_File (File_Name : in String;Ptr_Start: out Nodes.pNode) is\r
Use Nodes;\r
Parse_File:Boolean:=True;\r
Start_Symbol: Lexical.Lexeme;\r
Ptr_Start_S: Nodes.pNode:= new Node(None);\r
begin\r
Lexical.Open (File_Name);\r
Lexical.Next;\r
Parse_Show(Parse_File,Ptr_Start_S.Next);\r
Lexical.Close;\r
if Parse_File then\r
Ptr_Start:=Ptr_Start_S.Next;\r
-- Bounded_Strings.Set(Start_Symbol,"#START");\r
-- Symbol.Add(Start_Symbol,Symbol.Begining);\r
-- Symbol.Set_Code(Start_Symbol,Ptr_Start_S.Next);\r
else\r
Text_Io.Put ("not ok at" & integer'image(lexical.line_number) &\r
integer'image(lexical.column_number));\r
end if;\r
end Parse_File;\r
end Parser;\r
With Text_IO;\r
With Bounded_Strings;\r
With Error;\r
package body Reduct is\r
\r
package Int_IO is New Text_IO.Integer_IO(Integer);\r
\r
MaxAddress: constant := 99; -- limitations liees au format des trames\r
MaxValue: constant := 9999; -- Bitbus\r
\r
CurrentTime:integer:=0;\r
Reduct_Ok: Boolean:=TRUE; -- Vrai si pas d'erreur pendant la reduction\r
-- passe a Faux sinon pour empecher Production\r
\r
-- construction des noeuds de l'arbre reduit avec les 4 actions predef\r
function MkReductACT(periph,actor:integer) return pReductNode is\r
ptrNode:pReductNode;\r
begin\r
ptrNode:=New ReductNode(ACT);\r
ptrNode.TheType:=ACT;\r
ptrNode.Act_periph:=periph;\r
ptrNode.Act_actor:=actor;\r
ptrNode.TheTime:=CurrentTime;\r
return ptrNode;\r
end MkReductACT;\r
\r
function MkReductDES(periph,actor:integer) return pReductNode is\r
ptrNode:pReductNode;\r
begin\r
ptrNode:=New ReductNode(DES);\r
ptrNode.TheType:=DES;\r
ptrNode.Des_periph:=periph;\r
ptrNode.Des_actor:=actor;\r
ptrNode.TheTime:=CurrentTime;\r
return ptrNode;\r
end MkReductDES;\r
\r
function MkReductMOD(periph,actor,Nbre:integer) return pReductNode is\r
ptrNode:pReductNode;\r
begin\r
ptrNode:=New ReductNode(MODI);\r
ptrNode.TheType:=MODI;\r
ptrNode.Mod_periph:=periph;\r
ptrNode.Mod_actor:=actor;\r
ptrNode.Mod_Nbre:=Nbre;\r
ptrNode.TheTime:=CurrentTime;\r
return ptrNode;\r
end MkReductMOD;\r
\r
function MkReductEVO(periph,actor,Nbre1,Nbre2:integer) return pReductNode is\r
ptrNode:pReductNode;\r
begin\r
ptrNode:=New ReductNode(EVO);\r
ptrNode.TheType:=EVO;\r
ptrNode.Evo_periph:=periph;\r
ptrNode.Evo_actor:=actor;\r
ptrNode.Evo_Nbre1:=Nbre1;\r
ptrNode.Evo_Nbre2:=Nbre2;\r
ptrNode.TheTime:=CurrentTime;\r
return ptrNode;\r
end MkReductEVO;\r
\r
-- evaluation d'une expression\r
-- declaration incomplete, prototype\r
function ExprGetValue(aExprNode:Nodes.pNode) return Integer;\r
\r
function IdGetValue(aIdNode:Nodes.pNode) return integer is\r
begin\r
return Symbol.Get_Value(aIdNode.Id_Val);\r
end IdGetValue;\r
\r
function IdActorGetValue(periph: Lexical.Lexeme;\r
aIdNode:Nodes.pNode) return integer is\r
begin\r
return Symbol.Get_Actor_Number(periph,aIdNode.Id_Val);\r
end IdActorGetValue;\r
\r
function FactGetValue(aFactNode:Nodes.pNode) return Integer is\r
Use Nodes;\r
begin\r
case aFactNode.Fac_Node.TheType is\r
when Expression => return ExprGetValue(aFactNode.Fac_Node);\r
when id => return IdGetValue(aFactNode.Fac_Node);\r
when nombre => return Nodes.NbGetValue(aFactNode.Fac_Node);\r
when others => null;\r
end case;\r
end FactGetValue;\r
\r
procedure TermPrimeGetValue(Result_FactL:in out Integer;\r
aTermPrimeNode:Nodes.pNode) is\r
Use Nodes;\r
Use Error;\r
Result_FactR:Integer;\r
begin\r
Result_FactR:=FactGetValue(aTermPrimeNode.TerP_Fact);\r
case aTermPrimeNode.TerP_op is\r
when mul => Result_FactL:= Result_FactL * Result_FactR;\r
when div => if Result_FactR = 0 then\r
Reduct_Ok:=FALSE;\r
Result_FactL:=0;\r
Error.Handle(Divide_By_Zero);\r
else\r
Result_FactL:= Result_FactL / Result_FactR;\r
end if;\r
when modulo => Result_FactL:= Result_FactL mod Result_FactR;\r
when others => null;\r
end case;\r
-- si il y a d'autres TermePrime a calculer on recursive\r
if aTermPrimeNode.TerP_TermPrime/=null then\r
TermPrimeGetValue(Result_FactL,aTermPrimeNode.TerP_TermPrime);\r
end if;\r
end TermPrimeGetValue;\r
\r
function TermGetValue(aTermNode:Nodes.pNode) return Integer is\r
Use Nodes;\r
Result_FactL,Result_FactR:Integer;\r
begin\r
if aTermNode.TheType=Terme then\r
if aTermNode.Ter_Fact/= null then\r
result_factL:=FactGetValue(aTermNode.Ter_Fact);\r
end if;\r
if aTermNode.Ter_TermPrime/= null then\r
TermPrimeGetValue(result_FactL,aTermNode.Ter_TermPrime);\r
end if;\r
return Result_FactL;\r
else\r
return 0; -- erreur du programme\r
end if;\r
end TermGetValue;\r
\r
procedure ExprPrimeGetValue(Result_TermL:in out integer;\r
aExprPrimeNode:Nodes.pNode) is\r
Result_TermR:Integer;\r
Use Nodes;\r
begin\r
Result_TermR:=TermGetValue(aExprPrimeNode.ExpP_Term);\r
case aExprPrimeNode.ExpP_op is\r
when add => Result_TermL:=Result_TermL + Result_TermR;\r
when sub => Result_TermL:=Result_TermL - Result_TermR;\r
when others => null;\r
end case;\r
-- si il y a d'autres ExpressionPrime a calculer on recursive\r
if aExprPrimeNode.ExpP_ExprPrime/=null then\r
ExprPrimeGetValue(Result_TermL,aExprPrimeNode.ExpP_ExprPrime);\r
end if;\r
end ExprPrimeGetValue;\r
\r
function ExprGetValue(aExprNode:Nodes.pNode) return Integer is\r
Use Nodes;\r
Use Error;\r
Result_TermL,Result_TermR:Integer;\r
begin\r
if aExprNode.TheType=Expression then\r
if aExprNode.Exp_Term/= null then\r
result_TermL:=TermGetValue(aExprNode.Exp_Term);\r
end if;\r
if aExprNode.Exp_ExprPrime/= null then\r
ExprPrimeGetValue(result_TermL,aExprNode.Exp_ExprPrime);\r
end if;\r
return Result_TermL;\r
else\r
return 0; -- erreur du programme\r
end if;\r
end ExprGetValue;\r
\r
-- affichage d'une expression telle qu'elle est construite sous forme d'arbre\r
\r
procedure PrintIdActor(periph: Lexical.Lexeme;ptr: Nodes.pNode) is\r
begin\r
Text_IO.Put(Bounded_Strings.Image(ptr.Id_Val));\r
Text_IO.Put(' ');\r
Int_IO.Put(Symbol.Get_Actor_Number(periph,ptr.Id_Val)); -- pour table globale seulement\r
end PrintIdActor;\r
\r
procedure PrintId(ptr:Nodes.pNode) is\r
Use Nodes;\r
begin\r
if ptr/= Null then\r
Text_IO.Put(Bounded_Strings.Image(ptr.Id_Val));\r
Text_IO.Put(' ');\r
Int_IO.Put(Symbol.Get_Value(ptr.Id_Val));\r
end if;\r
end PrintId;\r
\r
-- prototype\r
procedure printExpr(aExprNode:Nodes.pNode);\r
\r
procedure printFact(aFactNode:Nodes.pNode) is\r
Use Nodes;\r
begin\r
case aFactNode.Fac_Node.TheType is\r
when Expression => printExpr(aFactNode.Fac_Node);\r
when id => printId(aFactNode.Fac_Node);\r
when nombre => Int_IO.Put(Nodes.NbGetValue(aFactNode.Fac_Node));\r
when others => null;\r
end case;\r
end printFact;\r
\r
procedure printTermPrime(aTermPrimeNode:Nodes.pNode) is\r
Use Nodes;\r
begin\r
case aTermPrimeNode.TerP_op is\r
when mul => Text_IO.Put("*");\r
when div => Text_IO.Put("/");\r
when modulo => Text_IO.Put("mod");\r
when others => null;\r
end case;\r
printFact(aTermPrimeNode.TerP_Fact);\r
-- si il y a d'autres TermPrime a calculer on recursive\r
if aTermPrimeNode.TerP_TermPrime/=null then\r
printTermPrime(aTermPrimeNode.TerP_TermPrime);\r
end if;\r
end printTermPrime;\r
\r
procedure printTerm(aTermNode:Nodes.pNode) is\r
Use Nodes;\r
begin\r
if aTermNode.TheType=Terme then\r
if aTermNode.Ter_Fact/= null then\r
printFact(aTermNode.Ter_Fact);\r
end if;\r
if aTermNode.Ter_TermPrime/= null then\r
printTermPrime(aTermNode.Ter_TermPrime);\r
end if;\r
end if;\r
end printTerm;\r
\r
procedure printExprPrime(aExprPrimeNode:Nodes.pNode) is\r
Use Nodes;\r
begin\r
case aExprPrimeNode.ExpP_op is\r
when add => Text_IO.Put("+");\r
when sub => Text_IO.Put("-");\r
when others => null;\r
end case;\r
printTerm(aExprPrimeNode.ExpP_Term);\r
-- si il y a d'autres ExpressionPrime a calculer on recursive\r
if aExprPrimeNode.ExpP_ExprPrime/=null then\r
printExprPrime(aExprPrimeNode.ExpP_ExprPrime);\r
end if;\r
end printExprPrime;\r
\r
procedure printExpr(aExprNode:Nodes.pNode) is\r
Use Nodes;\r
begin\r
if aExprNode.TheType=Expression then\r
if aExprNode.Exp_Term/= null then\r
printTerm(aExprNode.Exp_Term);\r
end if;\r
if aExprNode.Exp_ExprPrime/= null then\r
printExprPrime(aExprNode.Exp_ExprPrime);\r
end if;\r
end if;\r
end printExpr;\r
\r
-- affichage du contenu de l'arbre\r
\r
procedure printExprValue(aExprNode:Nodes.pNode) is\r
begin\r
Int_IO.Put(ExprGetValue(aExprNode));\r
Text_IO.Put(' ');\r
end PrintExprValue;\r
\r
procedure PrintAffect(ptr:Nodes.pNode) is\r
begin\r
PrintId(ptr.Aff_Id);\r
Text_IO.Put(" := ");\r
PrintExpr(ptr.Aff_Expr);\r
Text_IO.New_Line;\r
end PrintAffect;\r
\r
procedure PrintFaire(ptr:Nodes.pNode) is\r
Use Nodes;\r
begin\r
Text_IO.Put("-> Faire ");\r
PrintId(ptr.Fai_id1);\r
PrintId(ptr.Fai_id2);\r
Text_IO.New_Line;\r
end PrintFaire;\r
\r
procedure PrintActiver(ptr:Nodes.pNode) is\r
begin\r
Text_IO.Put(" -> Activer ");\r
PrintId(ptr.Act_id1);\r
PrintIdActor(ptr.Act_id1.Id_Val,ptr.Act_id2);\r
Text_IO.New_Line;\r
end PrintActiver;\r
\r
procedure PrintDesactiver(ptr:Nodes.pNode) is\r
begin\r
Text_IO.Put(" -> Desactiver ");\r
PrintId(ptr.Des_id1);\r
PrintIdActor(ptr.Des_id1.Id_Val,ptr.Des_id2);\r
Text_IO.New_Line;\r
end PrintDesactiver;\r
\r
procedure PrintModifier(ptr:Nodes.pNode) is\r
begin\r
Text_IO.Put(" -> Modifier ");\r
PrintId(ptr.Mod_id1);\r
PrintIdActor(ptr.Mod_id1.Id_Val,ptr.Mod_id2);\r
PrintExprValue(ptr.Mod_Expr);\r
Text_IO.New_Line;\r
end PrintModifier;\r
\r
procedure PrintEvoluer(ptr:Nodes.pNode) is\r
begin\r
Text_IO.Put(" -> Evoluer ");\r
PrintId(ptr.Evo_id1);\r
PrintIdActor(ptr.Evo_id1.Id_Val,ptr.Evo_id2);\r
PrintExprValue(ptr.Evo_Expr1);\r
PrintExprValue(ptr.Evo_Expr2);\r
Text_IO.New_Line;\r
end PrintEvoluer;\r
\r
procedure PrintRepeter(ptr:Nodes.pNode) is\r
begin\r
Text_IO.Put(" -------> Repeter ");\r
PrintExprValue(ptr.Rep_Expr);\r
Text_IO.New_Line;\r
PrintTree(ptr.Rep_Instr);\r
Text_IO.New_Line;\r
Text_IO.Put_Line(" -------> fin Repeter ");\r
end PrintRepeter;\r
\r
procedure PrintSinon(ptr:Nodes.pNode) is\r
begin\r
Text_IO.Put("--------> Sinon ");\r
PrintTree(ptr.Sin_Instr);\r
Text_IO.New_Line;\r
end PrintSinon;\r
\r
procedure PrintCond(ptr:Nodes.pNode) is\r
begin\r
Text_IO.Put(boolean'image(ptr.Con_Val));\r
end PrintCond;\r
\r
procedure PrintSi(ptr:Nodes.pNode) is\r
Use Nodes;\r
begin\r
Text_IO.Put("--------> Si ");\r
PrintCond(ptr.Si_Cond);\r
Text_IO.Put(" alors ");\r
Text_IO.New_Line;\r
PrintTree(ptr.Si_Instr);\r
if ptr.Si_Sinon/=null then\r
PrintSinon(ptr.Si_Sinon);\r
end if;\r
Text_IO.Put_Line("-------> fin Si ");\r
end PrintSi;\r
\r
procedure PrintAutemps(ptr:Nodes.pNode) is\r
begin\r
Text_IO.Put("--------> Autemps ");\r
PrintExprValue(ptr.Aut_Expr);\r
Text_IO.New_Line;\r
PrintTree(ptr.Aut_Instr);\r
Text_IO.New_Line;\r
Text_IO.Put_Line("-------> fin Autemps ");\r
end PrintAutemps;\r
\r
procedure PrintAttendre(ptr:Nodes.pNode) is\r
Use Nodes;\r
begin\r
Text_IO.Put("--------> Attendre ");\r
PrintExprValue(ptr.Att_Expr);\r
Text_IO.New_Line;\r
end PrintAttendre;\r
\r
procedure PrintTree(aTreeNode:Nodes.pNode) is\r
Use Nodes;\r
ptr:Nodes.pNode;\r
begin\r
ptr:=aTreeNode;\r
while ptr/=NULL loop\r
case ptr.TheType is\r
when affect => PrintAffect(ptr);\r
when faire => PrintFaire(ptr);\r
when activer => PrintActiver(ptr);\r
when desactiver => PrintDesactiver(ptr);\r
when modifier => PrintModifier(ptr);\r
when evoluer => PrintEvoluer(ptr);\r
when repeter => PrintRepeter(ptr);\r
when si => PrintSi(ptr);\r
when autemps => PrintAutemps(ptr);\r
when attendre => PrintAttendre(ptr);\r
when others => null;\r
end case;\r
ptr:=ptr.Next;\r
end loop;\r
end PrintTree;\r
\r
\r
-- evaluation d'une condition\r
function ConditionIsTrue(aCondNode:Nodes.pNode) return Boolean is\r
Use Nodes;\r
Nbre1,Nbre2:integer:=0;\r
begin\r
if aCondNode.Con_Expr1/=null then\r
Nbre1:=ExprGetValue(aCondNode.Con_Expr1);\r
if aCondNode.Con_Expr2/=null then\r
Nbre2:=ExprGetValue(aCondNode.Con_Expr2);\r
end if;\r
case aCondNode.Con_op is\r
when inf => return Nbre1<Nbre2;\r
when sup => return Nbre1>Nbre2;\r
when eq => return Nbre1=Nbre2;\r
when inf_eq => return Nbre1<=Nbre2;\r
when sup_eq => return Nbre1>=Nbre2;\r
when diff => return Nbre1/=Nbre2;\r
when NONE => return True;\r
end case;\r
else\r
return True; -- une Expression est toujours vraie\r
end if;\r
end ConditionIsTrue;\r
\r
function IsValid(Number1,Number2:integer;Max:integer)\r
return Boolean is\r
Use Error;\r
begin\r
if Number1>Max Or Number2>Max then -- Cas Nombre > Max\r
Reduct_Ok:=FALSE;\r
Error.Handle(Bitbus_Error);\r
end if;\r
if Number1<0 Or Number2<0 then -- Cas Nombre < 0\r
Reduct_Ok:=FALSE;\r
Error.Handle(Negativ_Number);\r
end if;\r
if Reduct_Ok then -- Ok\r
Return TRUE;\r
else\r
Return FALSE; -- Not Ok\r
end if;\r
end IsValid;\r
\r
procedure ReductActiver(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:out pReductNode) is\r
periph,actor,time:integer;\r
begin\r
periph:=IdGetValue(ptr.Act_id1);\r
actor:=IdActorGetValue(ptr.Act_id1.Id_Val,ptr.Act_id2);\r
if IsValid(periph,actor,MaxAddress) then\r
pHead:=MkReductACT(periph,actor);\r
end if;\r
pQueue:=pHead;\r
end ReductActiver;\r
\r
procedure ReductDesactiver(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:out pReductNode) is\r
periph,actor:integer;\r
begin\r
periph:=IdGetValue(ptr.Des_id1);\r
actor:=IdActorGetValue(ptr.Des_id1.Id_Val,ptr.Des_id2);\r
if IsValid(periph,actor,MaxAddress) then\r
pHead:=MkReductDES(periph,actor);\r
end if;\r
pQueue:=pHead;\r
end ReductDesactiver;\r
\r
procedure ReductModifier(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:out pReductNode) is\r
periph,actor,value1:integer;\r
begin\r
periph:=IdGetValue(ptr.Mod_id1);\r
actor:=IdActorGetValue(ptr.Mod_id1.Id_Val,ptr.Mod_id2);\r
value1:=ExprGetValue(ptr.Mod_Expr);\r
if IsValid(value1,0,MaxValue) then\r
if IsValid(periph,actor,MaxAddress) then\r
pHead:=MkReductMOD(periph,actor,value1);\r
end if;\r
end if;\r
pQueue:=pHead;\r
end ReductModifier;\r
\r
procedure ReductEvoluer(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:out pReductNode) is\r
periph,actor,value1,value2:integer;\r
begin\r
periph:=IdGetValue(ptr.Evo_id1);\r
actor:=IdActorGetValue(ptr.Evo_id1.Id_Val,ptr.Evo_id2);\r
value1:=ExprGetValue(ptr.Evo_Expr1);\r
value2:=ExprGetValue(ptr.Evo_Expr2);\r
if IsValid(value1,value2,MaxValue) then\r
if IsValid(periph,actor,MaxAddress) then\r
pHead:=MkReductEVO(periph,actor,value1,value2);\r
end if;\r
end if;\r
pQueue:=pHead;\r
end ReductEvoluer;\r
\r
-- prototype\r
procedure ReductBodyTree(PtraAbstractTree:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:in out pReductNode);\r
\r
procedure ReductAffect(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:in out pReductNode) is\r
Use Nodes;\r
Use Symbol;\r
aVariable:Lexical.Lexeme;\r
Valeur:Integer:=0;\r
begin\r
aVariable:=Nodes.IdGetLex(ptr.Aff_Id);\r
Valeur:=ExprGetValue(ptr.Aff_Expr);\r
Symbol.Set_Value(aVariable,Valeur);\r
pQueue:=pHead;\r
end ReductAffect;\r
\r
procedure ReductFaire(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:in out pReductNode) is\r
Use Nodes;\r
Use Symbol;\r
numero:integer:=1;\r
SsProgName,ArgId:Lexical.Lexeme;\r
ptrArg,pCode:Nodes.pNode;\r
begin\r
SsProgName:=Nodes.IdGetLex(ptr.Fai_Id1);\r
pCode:=Symbol.Get_Code(SsProgName);\r
Symbol.Set_Current_Table(SsProgName);\r
-- recuperer les params\r
ptrArg:=ptr.Fai_id2;\r
while ptrArg/=null loop\r
ArgId:=Nodes.IdGetLex(ptrArg);\r
Symbol.Set_Arg_Value(ArgId, numero);\r
ptrArg:=ptrArg.Next;\r
numero:=numero+1;\r
end loop;\r
ReductBodyTree(pCode,pHead,pQueue);\r
pHead:=pQueue;\r
Symbol.Reset_Current_Table; -- pour se repositionner sur la table prec\r
end ReductFaire;\r
\r
procedure ReductRepeter(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:in out pReductNode) is\r
Use Nodes;\r
times:integer;\r
begin\r
times:=ExprGetValue(ptr.Rep_Expr);\r
if IsValid(times,0,integer'Last) then\r
for i in 1..times loop\r
ReductBodyTree(ptr.Rep_Instr,pHead,pQueue);\r
pHead:=pQueue;\r
end loop;\r
else\r
pQueue:=pHead;\r
end if;\r
end ReductRepeter;\r
\r
procedure ReductSinon(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:in out pReductNode) is\r
begin\r
ReductBodyTree(ptr.Sin_Instr,pHead,pQueue);\r
end ReductSinon;\r
\r
procedure ReductSi(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:in out pReductNode) is\r
Use nodes;\r
begin\r
if ConditionIsTrue(ptr.Si_Cond) then\r
ReductBodyTree(ptr.Si_Instr,pHead,pQueue);\r
else\r
if ptr.Si_Sinon/=null then\r
ReductSinon(ptr.Si_Sinon,pHead,pQueue);\r
end if;\r
end if;\r
end ReductSi;\r
\r
procedure ReductAuTemps(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue: in out pReductNode) is\r
begin\r
CurrentTime:=ExprGetValue(ptr.Aut_Expr);\r
if IsValid(CurrentTime,0,integer'Last) then\r
ReductBodyTree(ptr.Aut_Instr,pHead,pQueue);\r
else\r
pQueue:=pHead;\r
end if;\r
end ReductAutemps;\r
\r
procedure ReductAttendre(ptr:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue: in out pReductNode) is\r
begin\r
CurrentTime:=CurrentTime+ExprGetValue(ptr.Att_Expr);\r
-- possibilite de faire Attendre ( <temps negatif> )\r
if CurrentTime<0 then\r
CurrentTime:=0;\r
end if;\r
pQueue:=pHead; -- pas de noeud cree ici\r
end ReductAttendre;\r
\r
procedure ReductBodyTree(PtraAbstractTree:Nodes.pNode;\r
pHead:in out pReductNode;\r
pQueue:in out pReductNode) is\r
Use Nodes;\r
ptr:Nodes.pNode;\r
LocalpHead:pReductNode;\r
begin\r
ptr:=PtraAbstractTree;\r
localpHead:=pHead;\r
while ptr/=null loop\r
\r
case ptr.TheType is\r
when activer => ReductActiver(ptr,LocalpHead.Next,pQueue);\r
when desactiver => ReductDesactiver(ptr,LocalpHead.Next,pQueue);\r
when modifier => ReductModifier(ptr,LocalpHead.Next,pQueue);\r
when evoluer => ReductEvoluer(ptr,LocalpHead.Next,pQueue);\r
when affect => ReductAffect(ptr,LocalpHead,pQueue);\r
when faire => ReductFaire(ptr,LocalpHead,pQueue);\r
when repeter => ReductRepeter(ptr,LocalpHead,pQueue);\r
when si => ReductSi(ptr,LocalpHead,pQueue);\r
when autemps => ReductAutemps(ptr,LocalpHead,pQueue);\r
when attendre => ReductAttendre(ptr,LocalpHead,pQueue);\r
when others => null;\r
end case;\r
if (ptr.TheType /= NONE) OR (ptr.TheType/=faire) then\r
LocalpHead:=pQueue;\r
end if;\r
ptr:=ptr.Next;\r
end loop;\r
end ReductBodyTree;\r
\r
function ReductTree(PtraAbstractTree:Nodes.pNode) return pReductNode is\r
pStartTree:pReductNode; -- debut arbre reduit a transmettre a PRODUCT\r
pBidon:pReductNode; -- sa valeur n'est pas utilisee , lie au codage\r
-- correspond a un pointeur sur la fin de l'arbre\r
-- reduit final\r
begin\r
pStartTree:=New ReductNode(NONE); -- ancre pour depart\r
Symbol.Init_Tables_Stack;\r
ReductBodyTree(PtraAbstractTree,pStartTree,pBidon);\r
if Reduct_Ok then\r
return pStartTree.Next; -- debut de l'arbre reduit\r
-- mission terminee , on passe la main a PRODUCT\r
else\r
return Null; -- pas de Production de code dans ce cas\r
end if;\r
end ReductTree;\r
\r
end Reduct;\r
with Nodes;\r
with Lexical;\r
with Bounded_Strings;\r
with Gen_Stack;\r
with Error;\r
with Text_Io;\r
package body Symbol is\r
\r
type Object (Length : positive);\r
type pObject is access Object;\r
\r
type Symbols (A_Kind : Kind := NONE) is record\r
Name : Lexical.Lexeme;\r
case A_Kind is\r
when Category =>\r
Actors : pObject := Null;\r
when Station =>\r
Sta_Type : Lexical.Lexeme; -- Un nom de categorie\r
Sta_Adress : Natural;\r
Sta_Category : pObject:= Null; -- Ptr sur table des acteurs\r
when Actor =>\r
Act_Type : Types := T_Void;\r
Act_Number : Natural range 0..Actor_Table_Size-1 := 0;\r
when Variable =>\r
Var_Type : Types := T_Void;\r
Var_Value : Integer := 0;\r
when Effect | Scene =>\r
Local_Table : pObject := Null;\r
Code : Nodes.pNode := Null;\r
when Begining =>\r
Beg_Code : Nodes.pNode := Null;\r
when Argument =>\r
Arg_Number : Positive := 1;\r
Arg_Value : Natural := 0; -- Un index dans la globale\r
when NONE =>\r
Null;\r
end case;\r
end record;\r
type pSymbols is access Symbols; -- MUTABLE !!!\r
type Symbols_Array is array (positive range<>) of pSymbols;\r
\r
type Object (Length : positive) is record\r
The_Previous : pObject;\r
The_Index : natural;\r
The_Content : Symbols_Array (1..Length);\r
end record;\r
\r
-- Pile des tables => profondeur d'appel de 20\r
package Table_Stack is new Gen_Stack (20, pObject);\r
\r
-- Variables du package symbol\r
\r
Null_Lexeme : Lexical.Lexeme;\r
Number : Natural := 0;\r
Current_Table : pObject := Null; -- Table Courante (Active)\r
Global_Table : pObject := Null; -- Table Globale\r
Symbol_Table_Stack : Table_Stack.Object; -- Pile des tables\r
\r
-- Fonctions de gestion locales\r
\r
function Is_In_Table (The_Name : in Lexical.Lexeme;\r
The_Table : in pObject) return boolean is\r
begin\r
for I in 1..The_Table.The_Index loop\r
if Bounded_Strings.Is_Equal (The_Table.The_Content(I).Name, The_Name)\r
then return True;\r
end if;\r
end loop;\r
return False;\r
end Is_In_Table;\r
\r
function Is_Existing (The_Name : in Lexical.Lexeme) return boolean is\r
Table_Pointer : pObject;\r
begin\r
Table_Pointer := Current_Table;\r
while Table_pointer /= Null loop\r
if Is_In_Table (The_Name, Table_Pointer) then\r
return True;\r
end if;\r
Table_Pointer := Table_Pointer.The_Previous;\r
end loop;\r
return False;\r
end Is_Existing;\r
\r
function Get_Index (From_Name : in Lexical.Lexeme;\r
In_Table : in pObject) return positive is\r
begin\r
for I in 1..In_Table.The_Index loop\r
if Bounded_Strings.Is_Equal (In_Table.The_Content(I).Name, From_Name)\r
then return I;\r
end if;\r
end loop;\r
end Get_Index;\r
\r
function Is_Arg_Number (The_Number : in Positive) return boolean is\r
begin\r
for I in 1..Current_Table.The_Index loop\r
if (Current_Table.The_Content(I).A_Kind = Argument) then\r
if (Current_Table.The_Content(I).Arg_Number = The_Number) then\r
return True;\r
end if;\r
end if;\r
end loop;\r
return False;\r
end Is_Arg_Number;\r
\r
\r
-- Creation/Liberation\r
\r
procedure New_Table (Length : in positive) is\r
Table_Pointer : pObject;\r
begin\r
Number := 0;\r
if (Current_Table = Null) then\r
Current_Table := new Object(Length);\r
Current_Table.The_Previous := Null;\r
Current_Table.The_Index := 0;\r
Global_table := Current_Table; -- Init du pointeur sur la globale\r
else\r
Table_Pointer := new Object(Length);\r
Table_Pointer.The_Previous := Current_Table;\r
Table_Pointer.The_Index := 0;\r
case Current_Table.The_Content(Current_Table.The_Index).A_Kind is\r
when Category =>\r
-- On rattache la table des acteurs a la categorie correspondante\r
-- Suppose que la derniere entree dans la table a ete cette categorie\r
Current_Table.The_Content(Current_Table.The_Index).Actors\r
:= Table_Pointer;\r
when Effect | Scene =>\r
-- On rattache la table locale a l'effet ou la scene correspondante\r
-- Suppose que la derniere entree dans la table a ete cet effet ou\r
-- cette scene !\r
Current_Table.The_Content(Current_Table.The_Index).Local_Table\r
:= Table_Pointer;\r
when Station | Actor | Variable | Begining | Argument | NONE =>\r
Null;\r
end case;\r
Current_Table := Table_Pointer;\r
end if;\r
end New_Table;\r
\r
procedure Release_Table is\r
begin\r
if Current_Table /= Global_Table then\r
Current_Table := Global_Table;\r
end if;\r
end Release_Table;\r
\r
\r
Procedure Init_Tables_Stack is\r
begin\r
Table_Stack.Push (Symbol_Table_Stack, Global_Table);\r
end Init_Tables_Stack;\r
\r
procedure Set_Current_Table (Name : in Lexical.Lexeme) is\r
Use Table_Stack;\r
Crt_Index : positive;\r
begin\r
if not Is_In_Table (Name, Global_Table) then\r
Error.Handle (Bounded_Strings.Image(Name) & " absent de la table !",\r
Error.Internal);\r
else\r
if Is_Full (Symbol_Table_Stack) then\r
Error.Handle ("pile des tables pleine !", Error.Internal);\r
else\r
Crt_Index := Get_Index (Name, Global_Table);\r
Current_Table := Global_Table.The_Content(Crt_Index).Local_Table;\r
Push (Symbol_Table_Stack, Current_Table);\r
end if;\r
end if;\r
end Set_Current_Table;\r
\r
procedure Reset_Current_Table is\r
Use Table_Stack;\r
begin\r
if Is_Empty (Symbol_Table_Stack) then\r
Error.Handle ("pile des tables vide !", Error.Internal);\r
Current_Table := Global_table;\r
Init_Tables_Stack;\r
else\r
Pop (Symbol_Table_Stack);\r
Current_Table := Get_Top (Symbol_Table_Stack);\r
end if;\r
end Reset_Current_Table;\r
\r
\r
-- Modification\r
\r
procedure Add (The_Name : in Lexical.Lexeme; Of_Kind : in Kind) is\r
Table_pointer : pObject;\r
Crt_Index : positive;\r
begin\r
if Current_Table.The_Index < Current_Table.Length then\r
if Is_Existing (The_Name) then\r
if Is_In_Table (The_Name, Global_Table) then\r
Table_Pointer := Global_Table;\r
else\r
Table_Pointer := Current_Table;\r
end if;\r
Crt_Index := Get_Index (The_Name, Table_Pointer);\r
if Table_Pointer.The_Content(Crt_Index).A_Kind /= Variable then\r
Error.Handle ("nom d'identificateur "\r
& Bounded_Strings.Image(The_Name)\r
& " deja utilise !", Error.External);\r
end if;\r
else\r
Current_Table.The_Index := Current_Table.The_Index + 1;\r
case of_Kind is\r
when Category =>\r
Current_Table.The_Content(Current_Table.The_Index) :=\r
new Symbols'(A_Kind => Category, Name => The_Name,\r
Actors => Null);\r
when Station =>\r
Current_Table.The_Content(Current_Table.The_Index) :=\r
new Symbols'(A_Kind => Station, Name => The_Name,\r
Sta_Type => Null_Lexeme,\r
Sta_Adress => 0,\r
Sta_Category => Null);\r
when Actor =>\r
Current_Table.The_Content(Current_Table.The_Index) :=\r
new Symbols'(A_Kind => Actor, Name => The_Name,\r
Act_Type => T_Error,\r
Act_Number => Number);\r
Number := Number + 1;\r
when Variable =>\r
Current_Table.The_Content(Current_Table.The_Index) :=\r
new Symbols'(A_Kind => Variable, Name => The_Name,\r
Var_Type => T_Error,\r
Var_Value => 0);\r
when Effect =>\r
Current_Table.The_Content(Current_Table.The_Index) :=\r
new Symbols'(A_Kind => Effect, Name => The_Name,\r
Local_Table => Null,\r
Code => Null);\r
when Scene =>\r
Current_Table.The_Content(Current_Table.The_Index) :=\r
new Symbols'(A_Kind => Scene, Name => The_Name,\r
Local_Table => Null,\r
Code => Null);\r
when Begining =>\r
Current_Table.The_Content(Current_Table.The_Index) :=\r
new Symbols'(A_Kind => Begining, Name => The_Name,\r
Beg_Code => Null);\r
when Argument =>\r
Number := Number + 1; -- car Number init et raj a 0\r
Current_Table.The_Content(Current_Table.The_Index) :=\r
new Symbols'(A_Kind => Argument, Name => The_Name,\r
Arg_Number => Number,\r
Arg_Value => 0);\r
when NONE =>\r
Null;\r
end case;\r
end if;\r
else\r
Error.Handle ("table des symboles pleine !!", Error.Internal);\r
end if;\r
end Add;\r
\r
procedure Set_Code (Name : in Lexical.Lexeme; The_Code : in Nodes.pNode) is\r
Crt_Index : positive;\r
begin\r
if not Is_In_Table (Name, Global_Table) then\r
Error.Handle ("symbole absent de la table globale !", Error.Internal);\r
else\r
Crt_index := Get_Index(Name, Global_Table);\r
case Global_Table.The_Content(Crt_Index).A_Kind is\r
when Effect | Scene =>\r
Global_Table.The_Content(Crt_Index).Code := The_Code;\r
when Begining =>\r
Global_Table.The_Content(Crt_Index).Beg_Code := The_Code;\r
when Category | Actor | Station | Variable | Argument | NONE =>\r
Null;\r
end case;\r
end if;\r
end Set_Code;\r
\r
procedure Set_Value (Name : in Lexical.Lexeme;\r
The_Value : in Integer) is\r
Table_Pointer : pObject;\r
Crt_Index : positive;\r
begin\r
if not Is_Existing (Name) then\r
Error.Handle (Bounded_Strings.Image(Name) &" inexistant !",\r
Error.Internal);\r
else\r
if Is_In_Table (Name, Current_Table) then\r
Table_Pointer := Current_Table;\r
else\r
Table_Pointer := Global_Table;\r
end if;\r
Crt_Index := Get_Index(Name, Table_Pointer);\r
case Table_Pointer.The_Content(Crt_Index).A_Kind is\r
when Station =>\r
Table_Pointer.The_Content(Crt_Index).Sta_Adress\r
:= The_Value;\r
when Variable =>\r
Table_Pointer.The_Content(Crt_Index).Var_Value\r
:= The_Value;\r
when Category | Actor | Effect | Scene | Argument | Begining | NONE\r
=> Null;\r
end case;\r
end if;\r
end Set_Value;\r
\r
procedure Set_Arg_Value (With_Value : in Lexical.Lexeme;\r
Arg_Number : in Positive) is\r
Crt_Index : positive;\r
begin\r
if not Is_Arg_Number (Arg_Number) then\r
Error.Handle ("argument " & Integer'Image(Arg_Number) & " inexistant !",\r
Error.Internal);\r
else\r
if not Is_In_Table (With_Value, Global_table) then\r
Error.Handle ("station " & Bounded_Strings.Image(With_Value)\r
& " inexistante !", Error.Internal);\r
else\r
Crt_Index := Get_Index (With_Value, Global_Table);\r
Current_Table.The_Content(Arg_Number).Arg_Value := Crt_Index;\r
end if;\r
end if;\r
end Set_Arg_Value;\r
\r
procedure Set_Type (Name : in Lexical.Lexeme; The_Type : in Types) is\r
Crt_Index : positive;\r
begin\r
if not Is_In_Table (Name, Current_Table) then\r
Error.Handle (Bounded_Strings.Image(Name) & " inexistant !",\r
Error.External);\r
else\r
Crt_Index := Get_Index(Name, Current_Table);\r
case Current_Table.The_Content(Crt_Index).A_Kind is\r
when Variable =>\r
Current_Table.The_Content(Crt_Index).Var_Type := The_Type;\r
when Actor =>\r
Current_Table.The_Content(Crt_Index).Act_Type := The_Type;\r
when Category | Station | Argument | Effect | Scene | Begining | NONE =>\r
Null;\r
end case;\r
end if;\r
end Set_Type;\r
\r
procedure Set_Type (From_Station : in Lexical.Lexeme;\r
With_Category : in Lexical.Lexeme) is\r
Crt_Index : positive;\r
begin\r
if not Is_In_Table (From_Station, Global_Table) then\r
Error.Handle ("station " & Bounded_Strings.Image(From_Station)\r
& " inexistante !", Error.Internal);\r
else\r
if not Is_In_Table (With_Category, Global_Table) then\r
Error.Handle ("categorie " & Bounded_Strings.Image(With_Category)\r
& " inexistante !", Error.External);\r
else\r
Crt_Index := Get_Index(From_Station, Global_Table);\r
if (Global_Table.The_Content(Crt_Index).A_Kind = Station) then\r
Bounded_Strings.Affect\r
(Global_Table.The_Content(Crt_Index).Sta_Type, With_Category);\r
Global_Table.The_Content(Crt_Index).Sta_Category :=\r
Global_Table.The_Content\r
(Get_Index(With_Category, Current_Table)).Actors;\r
else\r
Null;\r
end if;\r
end if;\r
end if;\r
end Set_Type;\r
\r
-- Consultation\r
\r
function Get_Code (From_Name : in Lexical.Lexeme) return Nodes.pNode is\r
Crt_Index : positive;\r
begin\r
if not Is_In_Table (From_Name, Global_Table) then\r
Error.Handle ("code de "&Bounded_Strings.Image(From_Name)&" absent !",\r
Error.Internal);\r
return Null;\r
else \r
Crt_Index := Get_Index (From_Name, Global_Table);\r
case Global_Table.The_Content(Crt_Index).A_Kind is\r
when Effect | Scene =>\r
return Global_Table.The_Content(Crt_Index).Code;\r
when Begining =>\r
return Global_Table.The_Content(Crt_Index).Beg_Code;\r
when Category | Actor | Station | Variable | Argument | NONE =>\r
return Null;\r
end case;\r
end if;\r
end Get_Code;\r
\r
function Get_Value (From_Name : in Lexical.Lexeme) return Integer is\r
Crt_Index : positive;\r
Table_Pointer : pObject;\r
begin\r
if not Is_Existing (From_Name) then\r
Error.Handle (Bounded_Strings.Image(From_Name) & " inexistant !",\r
Error.Internal);\r
return 0;\r
else\r
if Is_In_Table (From_Name, Current_Table) then\r
Table_Pointer := Current_Table;\r
else\r
Table_Pointer := Global_Table;\r
end if;\r
Crt_Index := Get_Index (From_Name, Table_Pointer);\r
case Table_Pointer.The_Content(Crt_Index).A_Kind is\r
when Station =>\r
return Table_Pointer.The_Content(Crt_Index).Sta_Adress;\r
when Variable =>\r
return Table_Pointer.The_Content(Crt_Index).Var_Value;\r
when Argument =>\r
Crt_Index := Table_Pointer.The_Content(Crt_Index).Arg_Value;\r
return Global_Table.The_Content(Crt_Index).Sta_Adress;\r
when Category | Actor | Effect | Scene | Begining | NONE =>\r
return 0;\r
end case;\r
end if;\r
end Get_Value;\r
\r
function Get_Sta_Actor (In_Station : in Lexical.Lexeme;\r
From_actor : in Lexical.Lexeme) return Integer is\r
Crt_Index : positive;\r
Table_Pointer : pObject;\r
begin\r
if not Is_In_Table (In_Station, Global_Table) then\r
Error.Handle ("station " & Bounded_Strings.Image(In_Station)\r
& " inexistante !", Error.Internal);\r
return 0;\r
else\r
Crt_Index := Get_Index (In_Station, Global_Table);\r
Table_Pointer := Global_Table.The_Content(Crt_Index).Sta_Category;\r
if not Is_In_Table (From_Actor, Table_Pointer) then\r
Error.Handle ("acteur " & Bounded_Strings.Image(From_Actor)\r
& " inexistant !", Error.Internal);\r
return 0;\r
else\r
Crt_Index := Get_Index (From_Actor, Table_Pointer);\r
return Table_Pointer.The_Content(Crt_Index).Act_Number;\r
end if;\r
end if;\r
end Get_Sta_Actor;\r
\r
function Get_Arg_Actor (In_Station : in Lexical.Lexeme;\r
From_actor : in Lexical.Lexeme) return Integer is\r
Crt_Index : positive;\r
Table_Pointer : pObject;\r
begin\r
Crt_Index := Get_Index (In_Station, Current_Table);\r
Crt_Index := Current_Table.The_Content(Crt_Index).Arg_Value;\r
Table_Pointer := Global_Table.The_Content(Crt_Index).Sta_Category;\r
if not Is_In_Table (From_Actor, Table_Pointer) then\r
Error.Handle ("acteur " & Bounded_Strings.Image(From_Actor)\r
& " inexistant !", Error.Internal);\r
return 0;\r
else\r
Crt_Index := Get_Index (From_Actor, Table_Pointer);\r
return Table_Pointer.The_Content(Crt_Index).Act_Number;\r
end if;\r
end Get_Arg_Actor;\r
\r
function Get_Actor_Number (In_Station : in Lexical.Lexeme;\r
From_actor : in Lexical.Lexeme) return Integer is\r
Crt_Index : positive;\r
Table_Pointer : pObject;\r
begin\r
if not Is_In_Table (In_Station, Current_Table) then\r
Table_Pointer := Global_Table;\r
else\r
Table_Pointer := Current_Table;\r
end if;\r
\r
Crt_Index := Get_Index (In_Station, Table_Pointer);\r
if (Table_Pointer.The_Content(Crt_Index).A_Kind = Argument) then\r
return Get_Arg_Actor (In_Station, From_Actor);\r
else\r
return Get_Sta_Actor (In_Station, From_Actor);\r
end if;\r
end Get_Actor_Number;\r
\r
function Get_Type (From_Name : in Lexical.Lexeme) return Types is\r
Crt_Index : positive;\r
Table_Pointer : pObject;\r
begin\r
if not Is_Existing (From_Name) then\r
Error.Handle (Bounded_Strings.Image(From_Name) & " inexistant !",\r
Error.Internal);\r
return T_Error;\r
else\r
if Is_In_Table (From_Name, Current_Table) then\r
Table_Pointer := Current_Table;\r
else\r
Table_Pointer := Global_Table;\r
end if;\r
Crt_Index := Get_Index (From_Name, Table_Pointer);\r
case Table_Pointer.The_Content(Crt_Index).A_Kind is\r
when Category =>\r
return T_Category;\r
when Station =>\r
return T_Station;\r
when Variable =>\r
return Current_Table.The_Content(Crt_Index).Var_Type;\r
when Effect =>\r
return T_Effect;\r
when Scene =>\r
return T_Scene;\r
when Begining =>\r
return T_Begining;\r
when Argument =>\r
return Get_type (Global_Table.The_Content\r
(Table_Pointer.The_Content(Crt_Index).Arg_Value).Name);\r
when Actor | NONE =>\r
return T_Error;\r
end case;\r
end if;\r
end Get_Type;\r
\r
function Get_Type (In_Station : in Lexical.Lexeme;\r
From_Actor : in Lexical.Lexeme) return Types is\r
Crt_Index : positive;\r
Table_Pointer : pObject;\r
begin\r
if not Is_In_Table (In_Station, Global_Table) then\r
Error.Handle ("station " & Bounded_Strings.Image(From_Actor)\r
& " inexistante !", Error.External);\r
return T_Error;\r
else\r
Crt_Index := Get_Index (In_Station, Global_Table);\r
Table_Pointer := Global_Table.The_Content(Crt_Index).Actors;\r
if not Is_In_Table (From_Actor, Table_Pointer) then\r
Error.Handle ("acteur " & Bounded_Strings.Image(From_Actor)\r
& "inexistant pour cette station !", Error.External);\r
return T_Error;\r
else\r
Crt_Index := Get_Index (From_Actor, Table_Pointer);\r
return Table_Pointer.The_Content(Crt_Index).Act_Type;\r
end if;\r
end if;\r
end Get_Type;\r
\r
\r
-- Tests\r
\r
procedure Print_Recur (P : in pObject) is\r
use Text_Io;\r
Done : boolean := false;\r
I : natural;\r
Index : natural;\r
begin\r
I := 1;\r
Put_Line ("Debut-------------");\r
while ((p /= Null) and then (not Done)) loop\r
Put (integer'image(I) & " ");\r
Put (Bounded_Strings.Image(P.The_Content(I).Name) & " ");\r
case P.The_Content(I).A_Kind is\r
when Category =>\r
Put_Line ("CAT");\r
Print_Recur (P.The_Content(I).Actors);\r
when Station =>\r
Put (Bounded_Strings.Image(P.The_Content(I).Sta_Type));\r
Put_Line (Integer'Image(P.The_Content(I).Sta_Adress));\r
-- Print_Recur (P.The_Content(I).Sta_Category);\r
when Actor =>\r
Put ("ACT ");\r
Put_Line (Integer'Image(P.The_Content(I).Act_Number));\r
when Variable =>\r
Put ("VAR = ");\r
Put_Line (Integer'Image(Get_Value (P.The_Content(I).Name)));\r
when Effect =>\r
Put_Line ("EFF");\r
Current_Table := P.The_Content(I).Local_Table;\r
Print_Recur (Current_table);\r
Release_Table;\r
when Scene =>\r
Put_Line ("SCE");\r
Current_Table := P.The_Content(I).Local_Table;\r
Print_Recur (Current_table);\r
Release_Table;\r
when Argument =>\r
Put ("ARG");\r
Put (Integer'Image(P.The_Content(I).Arg_Number)&" : ");\r
Index := P.The_Content(I).Arg_Value;\r
if Index /= 0 then\r
Put (Bounded_Strings.Image(Global_Table.The_Content(Index).Name));\r
Put_Line (Integer'Image (Get_Value (P.The_Content(I).Name)));\r
else\r
Put_Line ("0");\r
end if;\r
when Begining =>\r
Put_Line ("BEG");\r
when NONE =>\r
Null;\r
end case;\r
\r
if I >= P.The_Index then\r
Done := true;\r
else\r
I := I + 1;\r
end if;\r
end loop;\r
Put_Line ("Fin--------------");\r
end Print_Recur;\r
\r
procedure Print is\r
begin\r
Print_Recur (Current_Table);\r
end Print;\r
\r
end Symbol;\r
with Text_Io;\r
with lexical;\r
use Lexical;\r
\r
package body Error is\r
\r
type The_Follow is array (positive range <>) of Lexical.Token;\r
Follow_Of_Show: constant The_Follow:=(1=>L_Eof);\r
Follow_Of_Bloc_Materiel : constant The_Follow:=(1=>L_Implantation);\r
Follow_Of_Corps_Materiel : constant The_Follow:=(1=>L_Fin);\r
\r
procedure Handle (Message: in String;Internal: in Boolean) is\r
begin\r
if Internal then\r
Text_Io.Put_Line("Erreur : " & Message);\r
else\r
Text_Io.Put_Line("Erreur : " & Message & " en " &\r
integer'image(lexical.line_number) &\r
integer'image(lexical.column_number));\r
end if;\r
end;\r
\r
function Is_In_Table (The_Token : in Lexical.Token;\r
Item: Grammar) return Boolean is\r
In_Table:Boolean:=False;\r
begin\r
case Item is\r
when Show => for i In Follow_Of_Show'Range loop\r
if Follow_Of_Show(i) = The_Token then\r
In_Table:=True;\r
exit;\r
end if;\r
end loop;\r
return In_Table;\r
\r
when Bloc_Materiel => for i In Follow_Of_Bloc_Materiel'Range loop\r
if Follow_Of_Bloc_Materiel(i) = The_Token then\r
In_Table:=True;\r
exit;\r
end if;\r
end loop;\r
return In_Table;\r
when Corps_Materiel => for i In Follow_Of_Corps_Materiel'Range loop\r
if Follow_Of_Corps_Materiel(i) = The_Token then\r
In_Table:=True;\r
exit;\r
end if;\r
end loop;\r
return In_Table;\r
\r
when Others => null;\r
end case;\r
end Is_In_Table;\r
\r
\r
\r
procedure Handle (Message:in String;Item:in Grammar) is\r
begin\r
Error.Handle(Message, External);\r
case Item is\r
when Show => While Not Is_In_Table(Lexical.Get,Show) Loop\r
Lexical.Next;\r
end loop;\r
when Bloc_Materiel => While Not Is_In_Table(Lexical.Get,\r
Bloc_Materiel) Loop\r
Lexical.Next;\r
end loop;\r
when Corps_Materiel => While Not Is_In_Table(Lexical.Get,\r
Corps_Materiel) Loop\r
Lexical.Next;\r
end loop;\r
\r
when others => null;\r
end case;\r
end Handle;\r
\r
\r
procedure Handle (anErrorClass:in Collection) is\r
begin\r
Case anErrorClass is\r
when Divide_By_Zero => Text_IO.Put_Line("Erreur : Division par "\r
&"zero.");\r
when Negativ_Number => Text_IO.Put_Line("Erreur : Parametre negatif.");\r
when Bitbus_Error => Text_IO.Put_Line("Erreur : Adresse > 99 ou "\r
&" Parametres > 9999 , trame Bitbus incorrecte.");\r
End Case;\r
end Handle;\r
\r
end Error;\r
package body Gen_Stack is\r
\r
procedure Push (On : in out Object; The_Object : in Element) is\r
begin\r
On.The_Top := On.The_Top + 1;\r
On.The_Content(On.The_Top) := The_Object;\r
end Push;\r
\r
procedure Pop (From : in out Object) is\r
begin\r
From.The_Top := From.The_Top - 1;\r
end Pop;\r
\r
function Get_Top (From : in Object) return Element is\r
begin\r
return From.The_Content(From.The_Top);\r
end Get_Top;\r
\r
function Is_Full (The_Stack : in Object) return boolean is\r
begin\r
return The_Stack.The_Top = The_Stack.The_Content'Last;\r
end Is_Full;\r
\r
function Is_Empty (The_Stack : in Object) return boolean is\r
begin\r
return The_Stack.The_Top = 0;\r
end Is_Empty;\r
\r
end Gen_Stack;\r
With Formate,Text_IO;\r
Procedure TestFormate is\r
begin\r
Text_IO.Put_Line(Formate.IntToStr(1,2));\r
Text_IO.Put_Line(Formate.IntToStr(12,2));\r
Text_IO.Put_Line(Formate.IntToStr(1,4));\r
Text_IO.Put_Line(Formate.IntToStr(12,4));\r
Text_IO.Put_Line(Formate.IntToStr(123,4));\r
Text_IO.Put_Line(Formate.IntToStr(1234,4));\r
end TestFormate;\r
With Nodes,Text_IO;\r
procedure TestNodes is\r
ptrDebut,pPeriph,pActeur,pExpr:Nodes.pNode;\r
ptrCourant:Nodes.pNode;\r
begin\r
pPeriph:=Nodes.MkIdNode(70);\r
pActeur:=Nodes.MkIdNode(1);\r
ptrDebut:=Nodes.MkActiverNode(pPeriph,pActeur);\r
pPeriph:=Nodes.MkIdNode(65);\r
pActeur:=Nodes.MkIdNode(3);\r
pExpr:=Nodes.MkExprNode(null,null);\r
Nodes.ExprSetValue(pExpr,34);\r
ptrCourant:=Nodes.MkModifierNode(pPeriph,pActeur,pExpr);\r
ptrDebut.Next:=ptrCourant;\r
Nodes.PrintTree(ptrDebut);\r
end TestNodes;\r
With Text_IO,Tic;\r
procedure TestTic is\r
begin\r
Tic.SetTicRate(0.1); -- 1 s\r
for i in 1..20 loop\r
Tic.StartTic;\r
Text_IO.Put_Line("Une ligne tous les TicRate");\r
Tic.WaitForTic;\r
end loop;\r
Tic.ReleaseTic;\r
end TestTic;\r
With Text_IO,Nodes,Product;\r
procedure TestProduct is\r
ptrDebut,pPeriph,pActeur,pExpr:Nodes.pNode;\r
ptrCourant:Nodes.pNode;\r
begin\r
pPeriph:=Nodes.MkIdNode(70);\r
pActeur:=Nodes.MkIdNode(1);\r
ptrDebut:=Nodes.MkActiverNode(pPeriph,pActeur);\r
pPeriph:=Nodes.MkIdNode(65);\r
pActeur:=Nodes.MkIdNode(3);\r
pExpr:=Nodes.MkExprNode(null,null);\r
Nodes.ExprSetValue(pExpr,34);\r
ptrCourant:=Nodes.MkModifierNode(pPeriph,pActeur,pExpr);\r
ptrDebut.Next:=ptrCourant;\r
Nodes.PrintTree(ptrDebut);\r
Product.OpenOutPutFile;\r
Product.ProductTree(ptrDebut);\r
Product.CloseOutputFile;\r
end TestProduct;\r
with Bounded_Strings;\r
with Text_Io;\r
procedure Test_Bounded is\r
A_Var : Bounded_Strings.Variable_Strings(10);\r
begin\r
Bounded_Strings.Set (A_Var, "FFFFFFF");\r
Text_Io.Put_Line (Bounded_Strings.Image(A_Var));\r
Text_Io.Put_Line (integer'image(Bounded_Strings.To_Number(A_Var, 16)));\r
Text_Io.Put_Line ("ok");\r
end Test_Bounded;\r
with Parser;\r
with nodes;\r
with symbol;\r
with text_io;\r
procedure Test_Parser is\r
pt:Nodes.pNode;\r
n:natural:=0;\r
chaine:STRING(1..50);\r
begin\r
Text_IO.Put("Entrer le nom du fichier a jouer : ");\r
Text_IO.Get_Line(chaine,n);\r
Parser.Parse_File (chaine (1..n),pt);\r
end Test_Parser;\r
with Lexical;
with Text_Io;\r
with Bounded_Strings;\r
procedure Test_Lexical is
use Lexical;
N : natural := 0;\r
Chaine : string (1..50);\r
begin
Text_Io.Put ("Entrer le nom du fichier a analyser : ");\r
Text_Io.Get_Line (Chaine, N);\r
\r
Lexical.Open (Chaine(1..N));
while (not Lexical.At_End) loop
Lexical.Next;\r
Text_Io.Put (Integer'Image (Lexical.Line_Number));\r
Text_Io.Put (Integer'Image (Lexical.Column_Number) & " ");\r
Text_Io.Put (Bounded_Strings.Image (Lexical.Value) & " ");
Text_Io.Put_Line (Token'Image (Lexical.Get));
end loop;
Lexical.Close;
end Test_Lexical;
with Symbol;\r
with Lexical;\r
with text_io;\r
with Bounded_Strings;\r
Procedure Test_Symbol is\r
use Symbol;\r
use Bounded_Strings;\r
l,l1 : Lexical.Lexeme;\r
begin\r
New_Table (7);\r
\r
Set(l, "CD");\r
Add (l, Kind'(Category));\r
New_Table (2);\r
Set (l, "Act1");\r
Add (l, Kind'(Actor));\r
Set (l, "Act2");\r
Add (l, Kind'(Actor));\r
Release_Table;\r
\r
Set (l, "Cd1");\r
Set (l1, "CD");\r
Add (l, Kind'(Station));\r
Set_Station_Type(l,l1);\r
Set (l1, "100");\r
Set_Value (l, 100);\r
\r
Set (l, "Cd2");\r
Set (l1, "CD");\r
Add (l, Kind'(Station));\r
Set_Station_Type(l,l1);\r
Set (l1, "120");\r
Set_Value (l, 120);\r
\r
Set (l, "Act1");\r
Set (l1, "Cd1");\r
Text_Io.Put_Line (Integer'Image(Get_Actor_Number(l1, l)));\r
\r
Set (l, "Id1");\r
Add (l, Kind'(Variable));\r
Set (l1, "11");\r
Set_Value (l, 11);\r
\r
Set (l, "Id2");\r
Add (l, Kind'(Variable));\r
Set (l1, "22");\r
Set_Value (l, 22);\r
\r
Set (l, "Scene1");\r
Add (l, Kind'(Scene));\r
\r
New_Table (4);\r
Set (l, "Arg1");\r
Add (l, Kind'(Argument));\r
Set (l1, "Cd1");\r
Set_Arg_Value (l1, 1);\r
\r
Set (l, "Act2");\r
Set (l1, "Arg1");\r
Text_Io.Put_Line (Integer'Image(Get_Actor_Number(l1, l)));\r
\r
Set (l, "Arg2");\r
Add (l, Kind'(Argument));\r
Set (l1, "Cd2");\r
Set_Arg_Value (l1, 2);\r
\r
Set (l, "Arg3");\r
Add (l, Kind'(Argument));\r
Set (l1, "Cd1");\r
Set_Arg_Value (l1, 3);\r
\r
Set(l, "Id11");\r
Add (l, Kind'(Variable));\r
Set (l1, "11");\r
Set_Value (l, 11);\r
Release_Table;\r
\r
Set (l, "Id3");\r
Add (l, Kind'(Variable));\r
Set (l1, "33");\r
Set_Value (l, 33);\r
Print;\r
Release_Table;\r
end;\r
With Etape;\r
With Role;\r
With Scene;\r
With Text_IO;\r
With IO_Exceptions;\r
Procedure Moteur is\r
package Int_IO is new Text_IO.Integer_IO(Integer);\r
EndOfShow:Boolean:=FALSE;\r
S:Scene.Scene;\r
F:Text_IO.File_Type;\r
n:natural:=0;\r
chaine:STRING(1..50);\r
procedure release is\r
begin\r
Text_IO.New_Line;\r
Text_IO.Put_Line("-- Interpreteur de fichiers source SHOW-NET (v1.0) --");\r
Text_IO.Put_Line(" (c) BROCHET - CHAUVINEAU - FREYERMUTH 1994 ");\r
Text_IO.New_Line;\r
end release;\r
begin\r
release;\r
-- Test des E/S\r
loop\r
declare\r
begin\r
Text_IO.Put("Entrer le nom du fichier a jouer : ");\r
Text_IO.Get_Line(chaine,n);\r
Text_IO.Open(File=>F,Mode=>Text_IO.In_File,Name=>chaine(1..n));\r
S:=Scene.ChargerUneScene(F);\r
Text_IO.Close(F);\r
Scene.JouerUneScene(S);\r
EndOfShow:=TRUE;\r
exit when EndOfShow;\r
\r
exception\r
when IO_Exceptions.Name_Error =>Text_IO.Put_Line("Fichier "\r
&"introuvable, recommencez.");\r
when IO_Exceptions.Data_Error =>Text_IO.Put_Line("Type de fichier"\r
&" incorrect, recommencez.");\r
Text_IO.Close(F);\r
when IO_Exceptions.Status_Error =>Text_IO.Put_Line("Fichier vide,"\r
&" recommencez.");\r
Text_IO.Close(F);\r
when others =>\r
Text_Io.Put_Line("Erreur pendant l'animation.");\r
end;\r
end loop;\r
end Moteur;\r
With Text_IO;\r
With Reduct;\r
With Parser;\r
With Nodes;\r
With Product;\r
With IO_Exceptions;\r
procedure compilo is\r
Use Reduct;\r
Use Nodes;\r
package Int_IO is New Text_IO.Integer_IO(integer);\r
pStart:Nodes.pNode;\r
ptr:Reduct.pReductNode;\r
F:Text_IO.File_Type;\r
nIn,nOut:natural:=0;\r
Input_Name,Output_Name:STRING(1..50);\r
\r
procedure release is\r
begin\r
Text_IO.New_Line; \r
Text_IO.Put_Line("-- Compilateur de fichiers source SHOW-NET (v1.0) --");\r
Text_IO.Put_Line(" (c) BROCHET - CHAUVINEAU - FREYERMUTH 1994 ");\r
Text_IO.New_Line;\r
end release;\r
begin\r
release;\r
Text_IO.Put("Entrer le nom du fichier a compiler : ");\r
Text_IO.Get_Line(Input_Name,nIn);\r
Text_IO.Put("Entrer le nom du fichier en sortie : ");\r
Text_IO.Get_Line(Output_Name,nOut);\r
\r
Parser.Parse_File(Input_Name(1..nIn),pStart);\r
Nodes.PrintTree(pStart);\r
Reduct.PrintTree(pStart);\r
ptr:=Reduct.ReductTree(pStart);\r
Product.PrintTree(Ptr);\r
Product.OpenOutputFile(Output_Name(1..nOut));\r
Product.ProductTree(ptr);\r
Product.CloseOutputFile;\r
exception\r
when others =>\r
Text_IO.Put_Line("Erreur pendant la compilation.");\r
end compilo;\r