|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 20480 (0x5000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Acteurs, package body Materiels, package body Sem, seg_035a6c
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Text_Io;
package body Sem is
Max : constant := 255;
type Un_Acteur is
record
L_Acteur : Standard_String.Object;
L_Adresse : Integer;
Le_Type : Standard_String.Object;
end record;
type Une_Action is
record
L_Action : Standard_String.Object;
Le_Type : Standard_String.Object;
Le_Code : Integer;
end record;
Tableau_Actions : array (1 .. Max) of Une_Action;
Tableau_Acteurs : array (1 .. Max) of Un_Acteur;
Nombre_Actions : Integer range 0 .. Max;
Nombre_Acteurs : Integer range 0 .. Max;
package Materiels is
procedure Ouvrir_Bloc_Materiel;
procedure Fermer_Bloc_Materiel;
function Type_Existe (Un_Type : Standard_String.Object) return Boolean;
procedure Nouveau_Type (Un_Type : Standard_String.Object);
procedure Fin_Nouveau_Type;
procedure Nouvelle_Action (Une_Action : Standard_String.Object);
procedure Donner_Code_Action (Un_Code : Integer);
procedure Fin_Nouvelle_Action;
procedure Ouvrir_Champ_Option;
procedure Fermer_Champ_Option;
procedure Imprimer_Materiel;
end Materiels;
procedure Ouvrir_Bloc_Materiel is
begin
Materiels.Ouvrir_Bloc_Materiel;
end Ouvrir_Bloc_Materiel;
procedure Fermer_Bloc_Materiel is
begin
Materiels.Fermer_Bloc_Materiel;
end Fermer_Bloc_Materiel;
procedure Nouveau_Type (Un_Type : Standard_String.Object) is
begin
Materiels.Nouveau_Type (Un_Type);
end Nouveau_Type;
procedure Fin_Nouveau_Type is
begin
Materiels.Fin_Nouveau_Type;
end Fin_Nouveau_Type;
procedure Nouvelle_Action (Une_Action : Standard_String.Object) is
begin
Materiels.Nouvelle_Action (Une_Action);
end Nouvelle_Action;
procedure Donner_Code_Action (Un_Code : Integer) is
begin
Materiels.Donner_Code_Action (Un_Code);
end Donner_Code_Action;
procedure Fin_Nouvelle_Action is
begin
Materiels.Fin_Nouvelle_Action;
end Fin_Nouvelle_Action;
procedure Ouvrir_Champ_Option is
begin
Materiels.Ouvrir_Champ_Option;
end Ouvrir_Champ_Option;
procedure Fermer_Champ_Option is
begin
Materiels.Fermer_Champ_Option;
end Fermer_Champ_Option;
procedure Imprimer_Materiel is
begin
Materiels.Imprimer_Materiel;
end Imprimer_Materiel;
package body Materiels is
Index_Courant : Integer range 1 .. Max;
Type_Courant : Standard_String.Object;
Action_Courante : Standard_String.Object;
Code_Courant : Integer;
Erreur_Type : Boolean := False;
Erreur_Action : Boolean := False;
Erreur_Code : Boolean := False;
procedure Ouvrir_Bloc_Materiel is
begin
Index_Courant := 1;
end Ouvrir_Bloc_Materiel;
procedure Fermer_Bloc_Materiel is
begin
Nombre_Actions := Index_Courant - 1;
end Fermer_Bloc_Materiel;
function Type_Existe
(Un_Type : Standard_String.Object) return Boolean is
begin
for I in 1 .. (Index_Courant - 1) loop
if Standard_String."="
(Tableau_Actions (I).Le_Type, Un_Type) then
return True;
end if;
end loop;
return False;
end Type_Existe;
procedure Nouveau_Type (Un_Type : Standard_String.Object) is
begin
Erreur_Type := False;
if Type_Existe (Un_Type) then
Text_Io.Put_Line ("Le type '" &
Standard_String.Get_Contents (Un_Type) &
"' existe deja.");
Erreur_Type := True;
else
Standard_String.Copy (From => Un_Type, To => Type_Courant);
end if;
end Nouveau_Type;
procedure Fin_Nouveau_Type is
begin
null;
end Fin_Nouveau_Type;
function Action_Existe
(Un_Type : Standard_String.Object;
Une_Action : Standard_String.Object) return Boolean is
begin
for I in 1 .. (Index_Courant - 1) loop
if (Standard_String."="
(Tableau_Actions (I).Le_Type, Un_Type)) and then
(Standard_String."="
(Tableau_Actions (I).L_Action, Une_Action)) then
return True;
end if;
end loop;
return False;
end Action_Existe;
procedure Nouvelle_Action (Une_Action : Standard_String.Object) is
begin
if not (Erreur_Type) then
if Action_Existe (Type_Courant, Une_Action) then
Text_Io.Put_Line
("L'action '" &
Standard_String.Get_Contents (Une_Action) &
"' existe deja pour le type '" &
Standard_String.Get_Contents (Type_Courant) & "'.");
Erreur_Action := True;
else
Standard_String.Copy (From => Une_Action,
To => Action_Courante);
end if;
end if;
end Nouvelle_Action;
function Code_Existe
(Un_Type : Standard_String.Object; Un_Code : Integer)
return Boolean is
begin
for I in 1 .. (Index_Courant - 1) loop
if (Standard_String."="
(Tableau_Actions (I).Le_Type, Un_Type)) and then
(Tableau_Actions (I).Le_Code = Un_Code) then
return True;
end if;
end loop;
return False;
end Code_Existe;
procedure Donner_Code_Action (Un_Code : Integer) is
begin
if (not Erreur_Type) and then (not Erreur_Action) then
if Code_Existe (Type_Courant, Un_Code) then
Text_Io.Put_Line
("Le code '" & Integer'Image (Un_Code) &
"' est identique pour 2 actions differentes pour le type '" &
Standard_String.Get_Contents (Type_Courant) & "'.");
Erreur_Code := True;
else
Code_Courant := Un_Code;
end if;
end if;
end Donner_Code_Action;
procedure Fin_Nouvelle_Action is
begin
if Index_Courant = Max then
Text_Io.Put_Line ("Depassement_Index");
end if;
if (not Erreur_Type) and then
(not Erreur_Action) and then (not Erreur_Code) then
Standard_String.Copy
(From => Action_Courante,
To => Tableau_Actions (Index_Courant).L_Action);
Standard_String.Copy
(From => Type_Courant,
To => Tableau_Actions (Index_Courant).Le_Type);
Tableau_Actions (Index_Courant).Le_Code := Code_Courant;
Index_Courant := Index_Courant + 1;
end if;
Erreur_Action := False;
Erreur_Code := False;
end Fin_Nouvelle_Action;
procedure Ouvrir_Champ_Option is
begin
null;
end Ouvrir_Champ_Option;
procedure Fermer_Champ_Option is
begin
null;
end Fermer_Champ_Option;
procedure Imprimer_Materiel is
begin
for I in 1 .. Nombre_Actions loop
Text_Io.Put_Line
("Nom action : " & Standard_String.Get_Contents
(Tableau_Actions (I).L_Action) &
" Type materiel : " &
(Standard_String.Get_Contents
(Tableau_Actions (I).Le_Type) & " Code bitbus : " &
Integer'Image (Tableau_Actions (I).Le_Code)));
end loop;
Text_Io.Put_Line ("");
Text_Io.Put_Line ("");
end Imprimer_Materiel;
end Materiels;
package Acteurs is
procedure Ouvrir_Bloc_Acteur;
procedure Fermer_Bloc_Acteur;
procedure Nouvel_Acteur (Un_Acteur : Standard_String.Object);
procedure Fin_Nouvel_Acteur;
procedure Donner_Type_Acteur (Un_Type : Standard_String.Object);
procedure Donner_Adresse_Station (Une_Adresse : Integer);
procedure Imprimer_Acteur;
end Acteurs;
procedure Ouvrir_Bloc_Acteur is
begin
Acteurs.Ouvrir_Bloc_Acteur;
end Ouvrir_Bloc_Acteur;
procedure Fermer_Bloc_Acteur is
begin
Acteurs.Fermer_Bloc_Acteur;
end Fermer_Bloc_Acteur;
procedure Nouvel_Acteur (Un_Acteur : Standard_String.Object) is
begin
Acteurs.Nouvel_Acteur (Un_Acteur);
end Nouvel_Acteur;
procedure Fin_Nouvel_Acteur is
begin
Acteurs.Fin_Nouvel_Acteur;
end Fin_Nouvel_Acteur;
procedure Donner_Type_Acteur (Un_Type : Standard_String.Object) is
begin
Acteurs.Donner_Type_Acteur (Un_Type);
end Donner_Type_Acteur;
procedure Donner_Adresse_Station (Une_Adresse : Integer) is
begin
Acteurs.Donner_Adresse_Station (Une_Adresse);
end Donner_Adresse_Station;
procedure Imprimer_Acteur is
begin
Acteurs.Imprimer_Acteur;
end Imprimer_Acteur;
package body Acteurs is
Index_Courant : Integer range 1 .. Max;
Type_Courant : Standard_String.Object;
Acteur_Courant : Standard_String.Object;
Adresse_Courante : Integer := 0;
Erreur_Type : Boolean := False;
Erreur_Acteur : Boolean := False;
Erreur_Adresse : Boolean := False;
procedure Ouvrir_Bloc_Acteur is
begin
Index_Courant := 1;
end Ouvrir_Bloc_Acteur;
procedure Fermer_Bloc_Acteur is
begin
Nombre_Acteurs := Index_Courant - 1;
end Fermer_Bloc_Acteur;
function Acteur_Existe
(Un_Acteur : Standard_String.Object) return Boolean is
begin
for I in 1 .. (Index_Courant - 1) loop
if Standard_String."="
(Tableau_Acteurs (I).L_Acteur, Un_Acteur) then
return True;
end if;
end loop;
return False;
end Acteur_Existe;
procedure Nouvel_Acteur (Un_Acteur : Standard_String.Object) is
begin
Erreur_Acteur := False;
if Acteur_Existe (Un_Acteur) then
Text_Io.Put_Line ("L'acteur '" &
Standard_String.Get_Contents (Un_Acteur) &
"' existe deja.");
Erreur_Acteur := True;
else
Standard_String.Copy (From => Un_Acteur, To => Acteur_Courant);
end if;
end Nouvel_Acteur;
function Type_Existe
(Un_Type : Standard_String.Object) return Boolean is
begin
for I in 1 .. Nombre_Actions loop
if Standard_String."="
(Tableau_Actions (I).Le_Type, Un_Type) then
return True;
end if;
end loop;
return False;
end Type_Existe;
procedure Donner_Type_Acteur (Un_Type : Standard_String.Object) is
begin
if not Erreur_Acteur then
if not Type_Existe (Un_Type) then
Text_Io.Put_Line ("Le type '" &
Standard_String.Get_Contents (Un_Type) &
"' n'existe pas.");
Erreur_Type := True;
else
Standard_String.Copy (From => Un_Type, To => Type_Courant);
end if;
end if;
end Donner_Type_Acteur;
function Adresse_Existe (Une_Adresse : Integer) return Boolean is
begin
for I in 1 .. (Index_Courant - 1) loop
if Tableau_Acteurs (I).L_Adresse = Une_Adresse then
return True;
end if;
end loop;
return False;
end Adresse_Existe;
procedure Donner_Adresse_Station (Une_Adresse : Integer) is
begin
if not Erreur_Acteur and then not Erreur_Type then
if Adresse_Existe (Une_Adresse) then
Text_Io.Put_Line ("L'adresse '" &
Integer'Image (Une_Adresse) &
"' existe deja.");
Erreur_Adresse := True;
else
Adresse_Courante := Une_Adresse;
end if;
end if;
end Donner_Adresse_Station;
procedure Fin_Nouvel_Acteur is
begin
if not Erreur_Acteur and then
not Erreur_Type and then not Erreur_Adresse then
Standard_String.Copy
(From => Acteur_Courant,
To => Tableau_Acteurs (Index_Courant).L_Acteur);
Standard_String.Copy
(From => Type_Courant,
To => Tableau_Acteurs (Index_Courant).Le_Type);
Tableau_Acteurs (Index_Courant).L_Adresse := Adresse_Courante;
Index_Courant := Index_Courant + 1;
end if;
Erreur_Type := False;
Erreur_Adresse := False;
end Fin_Nouvel_Acteur;
procedure Imprimer_Acteur is
begin
for I in 1 .. Nombre_Acteurs loop
Text_Io.Put_Line
("Nom acteur : " & Standard_String.Get_Contents
(Tableau_Acteurs (I).L_Acteur) &
" Type materiel : " &
(Standard_String.Get_Contents
(Tableau_Acteurs (I).Le_Type) & " Adresse : " &
Integer'Image (Tableau_Acteurs (I).L_Adresse)));
end loop;
end Imprimer_Acteur;
end Acteurs;
end Sem;
nblk1=13
nid=e
hdr6=24
[0x00] rec0=25 rec1=00 rec2=01 rec3=02e
[0x01] rec0=01 rec1=00 rec2=04 rec3=02e
[0x02] rec0=29 rec1=00 rec2=0b rec3=012
[0x03] rec0=29 rec1=00 rec2=0a rec3=020
[0x04] rec0=1e rec1=00 rec2=07 rec3=02e
[0x05] rec0=1e rec1=00 rec2=09 rec3=010
[0x06] rec0=17 rec1=00 rec2=06 rec3=08a
[0x07] rec0=1c rec1=00 rec2=11 rec3=022
[0x08] rec0=1f rec1=00 rec2=02 rec3=028
[0x09] rec0=19 rec1=00 rec2=10 rec3=05e
[0x0a] rec0=02 rec1=00 rec2=08 rec3=020
[0x0b] rec0=2e rec1=00 rec2=0d rec3=02e
[0x0c] rec0=21 rec1=00 rec2=03 rec3=016
[0x0d] rec0=00 rec1=00 rec2=13 rec3=00a
[0x0e] rec0=1c rec1=00 rec2=0f rec3=01c
[0x0f] rec0=1d rec1=00 rec2=05 rec3=020
[0x10] rec0=18 rec1=00 rec2=0c rec3=024
[0x11] rec0=1e rec1=00 rec2=12 rec3=000
[0x12] rec0=10 rec1=00 rec2=0e rec3=000
tail 0x2152edc8e84da7d4e80cf 0x42a00088462060003
Free Block Chain:
0xe: 0000 00 00 01 68 00 2a 20 20 20 20 20 20 20 20 20 20 ┆ h * ┆