|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 37888 (0x9400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Our_Value, seg_049272
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Ext_String, Lex, Text_Io;
use Ext_String, Lex;
package body Our_Value is
----------------------------------------------------------------------------
-- Procedures de traitement des exceptions --
----------------------------------------------------------------------------
procedure Signal_Not_Implemented is
begin
Print ("Desole, Cette fonction n'est pas encore implementee!");
Print_New_Line;
end Signal_Not_Implemented;
----------------------------------------------------------------------------
function Verify_Type
(Val : Var_Value; Type_Var : Var_Type) return Boolean is
begin
if (Val.My_Type = Undefined) or else (Type_Var = Undefined) then
Print ("Il y a une operation sur une variable indefinie");
Print_New_Line;
return False;
elsif (Val.My_Type /= Type_Var) then
case Val.My_Type is
when Undefined =>
Print ("Operation illegale sur une variable indefinie");
Print_New_Line;
when Type_Value =>
Print ("Operation illegale sur un pointeur sur VAR_VALUE");
Print_New_Line;
when Type_Token =>
Print ("Operation illegale sur une variable jeton");
Print_New_Line;
when Type_Boolean =>
Print ("Operation illegale sur une variable booleenne");
Print_New_Line;
when Type_Integer =>
Print ("Operation illegale sur une variable entiere");
Print_New_Line;
when Type_String =>
Print ("Operation illegale sur une variable chaine");
Print_New_Line;
end case;
return False;
else
return True;
end if;
end Verify_Type;
----------------------------------------------------------------------------
-- procedures d'affectation (Set_Value => ":=") --
----------------------------------------------------------------------------
procedure Set_Value (Target : in out Var_Value; Source : Var_Value) is
begin
if Verify_Type (Source, Type_Token) and then
Verify_Type (Target, Type_Token) then
Verify_Print ("Target.My_Token <- " & Convert (Source.My_Token));
Verify_New_Line;
Target.My_Token := Source.My_Token;
elsif Verify_Type (Source, Type_Boolean) and then
Verify_Type (Target, Type_Token) then
Verify_Print ("Target.My_Boolean <- " &
Convert (Source.My_Boolean));
Verify_New_Line;
Target.My_Boolean := Source.My_Boolean;
elsif Verify_Type (Source, Type_Integer) and then
Verify_Type (Target, Type_Token) then
Verify_Print ("Target.My_Integer <- " &
Convert (Source.My_Integer));
Verify_New_Line;
Target.My_Integer := Source.My_Integer;
elsif Verify_Type (Source, Type_String) and then
Verify_Type (Target, Type_Token) then
Verify_Print ("Target.My_String <- " & Source.My_String);
Verify_New_Line;
Copy (Target.My_String, Source.My_String);
else
Print
("Il y a une tentative d'affectation entre des types incompatibles!");
raise Type_Conflict;
end if;
end Set_Value;
procedure Set_Value (Target : in out Var_Value; Source : P_Value) is
begin
if Verify_Type (Target, Type_Value) then
Verify_Print ("Target.My_Value <- P_Value");
Verify_New_Line;
Target.My_Value := Source;
end if;
end Set_Value;
procedure Set_Value (Target : in out Var_Value; Source : Lex.Token) is
begin
if Verify_Type (Target, Type_Token) then
Verify_Print ("Target.My_Token <- " & Convert (Source));
Verify_New_Line;
Target.My_Token := Source;
end if;
end Set_Value;
procedure Set_Value (Target : in out Var_Value; Source : Boolean) is
begin
if Verify_Type (Target, Type_Boolean) then
Verify_Print ("Target.My_Boolean <- " & Convert (Source));
Verify_New_Line;
Target.My_Boolean := Source;
end if;
end Set_Value;
procedure Set_Value (Target : in out Var_Value; Source : Integer) is
begin
if Verify_Type (Target, Type_Integer) then
Verify_Print ("Target.My_Integer <- " & Convert (Source));
Verify_New_Line;
Target.My_Integer := Source;
end if;
end Set_Value;
procedure Set_Value (Target : in out Var_Value; Source : Var_String) is
Local_Token : Lex.Token;
Local_Boolean : Boolean;
Local_Integer : Integer;
begin
if Is_Token_Op (Source) and then Verify_Type (Target, Type_Token) then
Local_Token := Convert (Source);
Set_Value (Target, Local_Token);
elsif Is_Boolean (Source) and then
Verify_Type (Target, Type_Boolean) then
Local_Boolean := Convert (Source);
Set_Value (Target, Local_Boolean);
elsif Is_Integer (Source) and then
Verify_Type (Target, Type_Integer) then
Local_Integer := Convert (Source);
Set_Value (Target, Local_Integer);
else
if Verify_Type (Target, Type_String) then
Verify_Print ("Target.My_String <- " & Source);
Verify_New_Line;
Copy (Target.My_String, Source);
end if;
end if;
end Set_Value;
----------------------------------------------------------------------------
-- fonctions de consultations --
----------------------------------------------------------------------------
function Get_Type (Val : Var_Value) return Var_Type is
begin
case Val.My_Type is
when Undefined =>
Verify_Print ("Get_Type -> Undefined");
when Type_Value =>
Verify_Print ("Get_Type -> Type_Value");
when Type_Token =>
Verify_Print ("Get_Type -> Type_Token");
when Type_Boolean =>
Verify_Print ("Get_Type -> Type_Boolean");
when Type_Integer =>
Verify_Print ("Get_Type -> Type_Integer");
when Type_String =>
Verify_Print ("Get_Type -> Type_String");
end case;
Verify_New_Line;
return Val.My_Type;
end Get_Type;
function Get_Type (Val : P_Value) return Var_Type is
begin
Verify_Print ("Get_Type -> Type_Value");
Verify_New_Line;
return Type_Value;
end Get_Type;
function Get_Type (Val : Lex.Token) return Var_Type is
begin
Verify_Print ("Get_Type -> Type_Token");
Verify_New_Line;
return Type_Token;
end Get_Type;
function Get_Type (Val : Boolean) return Var_Type is
begin
Verify_Print ("Get_Type -> Type_Boolean");
Verify_New_Line;
return Type_Boolean;
end Get_Type;
function Get_Type (Val : Integer) return Var_Type is
begin
Verify_Print ("Get_Type -> Type_Integer");
Verify_New_Line;
return Type_Integer;
end Get_Type;
function Get_Type (Val : Var_String) return Var_Type is
begin
Verify_Print ("Get_Type -> Type_String");
Verify_New_Line;
return Type_String;
end Get_Type;
----------------------------------------------------------------------------
function Get_Value (Val : Var_Value) return Lex.Token is
begin
if Verify_Type (Val, Type_Token) then
Verify_Print ("Get_Type -> " & Convert (Val.My_Token));
Verify_New_Line;
return Val.My_Token;
else
raise Type_Conflict;
end if;
end Get_Value;
function Get_Value (Val : Var_Value) return Boolean is
begin
if Verify_Type (Val, Type_Boolean) then
Verify_Print ("Get_Value -> " & Convert (Val.My_Boolean));
Verify_New_Line;
return Val.My_Boolean;
else
raise Type_Conflict;
end if;
end Get_Value;
function Get_Value (Val : Var_Value) return Integer is
begin
if Verify_Type (Val, Type_Integer) then
Verify_Print ("Get_Value -> " & Convert (Val.My_Integer));
Verify_New_Line;
return Val.My_Integer;
else
raise Type_Conflict;
end if;
end Get_Value;
function Get_Value (Val : Var_Value) return Var_String is
begin
if Verify_Type (Val, Type_String) then
Verify_Print ("Get_Value -> " & Val.My_String);
Verify_New_Line;
return Val.My_String;
else
raise Type_Conflict;
end if;
end Get_Value;
----------------------------------------------------------------------------
function Get_Value (Val : P_Value) return Lex.Token is
Local : Var_Value (Type_Value);
begin
Set_Value (Local, Val);
return Get_Value (Local);
end Get_Value;
function Get_Value (Val : P_Value) return Boolean is
Local : Var_Value (Type_Value);
begin
Set_Value (Local, Val);
return Get_Value (Local);
end Get_Value;
function Get_Value (Val : P_Value) return Integer is
Local : Var_Value (Type_Value);
begin
Set_Value (Local, Val);
return Get_Value (Local);
end Get_Value;
function Get_Value (Val : P_Value) return Var_String is
Local : Var_Value (Type_Value);
begin
Set_Value (Local, Val);
return Get_Value (Local);
end Get_Value;
----------------------------------------------------------------------------
procedure Print_Value (Val : P_Value) is
Local : Var_String;
begin
Verify_Print ("Print_Value :");
case Val.My_Type is
when Undefined =>
Print ("indefinie");
when Type_Value =>
Print_Value (Val.My_Value);
when Type_Token =>
Print (Convert (Val.My_Token));
when Type_Boolean =>
Print (Convert (Val.My_Boolean));
when Type_Integer =>
Print (Convert (Val.My_Integer));
when Type_String =>
Print (Val.My_String);
end case;
Verify_New_Line;
end Print_Value;
procedure Print_Value (Val : Var_Value) is
Local : Var_String;
begin
Verify_Print ("Print_Value :");
case Val.My_Type is
when Undefined =>
Print ("indefinie");
when Type_Value =>
Print_Value (Val.My_Value);
when Type_Token =>
Print (Convert (Val.My_Token));
when Type_Boolean =>
Print (Convert (Val.My_Boolean));
when Type_Integer =>
Print (Convert (Val.My_Integer));
when Type_String =>
Print (Val.My_String);
end case;
Verify_New_Line;
end Print_Value;
----------------------------------------------------------------------------
-- Fonctions sur des operations unaires --
----------------------------------------------------------------------------
function Op (Operator : Lex.Token; Val : Var_Value) return Boolean is
Val_Str : Var_String;
Local : Boolean;
begin
if Verify_Type (Val, Type_Boolean) then
if (Operator = Non) then
Copy (Val_Str, "non " & Convert (Val.My_Boolean));
Copy (Val_Str, Val_Str & " -> ");
Local := not Val.My_Boolean;
else
Copy (Val_Str, "Operation booleenne inconnue");
raise Type_Conflict;
end if;
else
Copy (Val_Str, "VAR_VALUE n'est pas de type TYPE_BOOLEAN");
raise Type_Conflict;
end if;
Verify_Print (Val_Str & Convert (Local));
Verify_New_Line;
return Local;
exception
when Type_Conflict =>
Print (Val_Str & " -> Type_Conflict");
Print_New_Line;
return False;
raise;
when others =>
Print (Val_Str & " -> exception non traitee");
Print_New_Line;
raise;
end Op;
----------------------------------------------------------------------------
function Op (Operator : Lex.Token; Val : Var_Value) return Integer is
Val_Str : Var_String;
Local : Integer;
begin
if Verify_Type (Val, Type_Integer) then
if (Operator = Plus) then
Copy (Val_Str, "+ " & Convert (Val.My_Integer));
Copy (Val_Str, Val_Str & " -> ");
Local := Val.My_Integer;
elsif (Operator = Minus) then
Copy (Val_Str, "- " & Convert (Val.My_Integer));
Copy (Val_Str, Val_Str & " -> ");
Local := -Val.My_Integer;
else
Copy (Val_Str, "Operateur entier inconnu");
raise Type_Conflict;
end if;
else
Copy (Val_Str, "VAR_VALUE n'est pas de type TYPE_INTEGER");
raise Type_Conflict;
end if;
Verify_Print (Val_Str & Convert (Local));
Verify_New_Line;
return Local;
exception
when Type_Conflict =>
Print (Val_Str & " -> Type_Conflict");
Print_New_Line;
return 0;
raise;
when others =>
Print (Val_Str & " -> Exception non traitee");
Print_New_Line;
raise;
end Op;
----------------------------------------------------------------------------
-- Fonctions sur des operations binaires --
----------------------------------------------------------------------------
function Op (Operator : Lex.Token; Val1, Val2 : Var_Value) return Boolean is
Val_Str : Var_String;
Local : Boolean;
begin
if (Val1.My_Type = Type_Boolean) and then
(Val2.My_Type = Type_Boolean) then
if (Operator = Et) then
Local := (Val1.My_Boolean and Val2.My_Boolean);
elsif (Operator = Ou) then
Local := (Val1.My_Boolean or Val2.My_Boolean);
elsif (Operator = Equal) then
Local := (Val1.My_Boolean = Val2.My_Boolean);
elsif (Operator = Not_Equal) then
Local := (Val1.My_Boolean /= Val2.My_Boolean);
else
Copy (Val_Str, "Operateur booleen inconnu");
raise Type_Conflict;
end if;
Copy (Val_Str, Convert (Val1.My_Boolean) & " ");
Copy (Val_Str, Val_Str & Convert (Operator) & " ");
Copy (Val_Str, Val_Str & Convert (Val2.My_Boolean));
Copy (Val_Str, Val_Str & " -> ");
elsif (Val1.My_Type = Type_Integer) and then
(Val2.My_Type = Type_Integer) then
if (Operator = Equal) then
Local := (Val1.My_Integer = Val2.My_Integer);
elsif (Operator = Not_Equal) then
Local := (Val1.My_Integer /= Val2.My_Integer);
elsif (Operator = Less) then
Local := (Val1.My_Integer < Val2.My_Integer);
elsif (Operator = Less_Equal) then
Local := (Val1.My_Integer <= Val2.My_Integer);
elsif (Operator = Great) then
Local := (Val1.My_Integer > Val2.My_Integer);
elsif (Operator = Great_Equal) then
Local := (Val1.My_Integer >= Val2.My_Integer);
else
Copy (Val_Str, "Operateur entier inconnu");
raise Type_Conflict;
end if;
Copy (Val_Str, Convert (Val1.My_Integer) & " ");
Copy (Val_Str, Val_Str & Convert (Operator) & " ");
Copy (Val_Str, Val_Str & Convert (Val2.My_Integer));
Copy (Val_Str, Val_Str & " -> ");
elsif (Val1.My_Type = Type_String) and then
(Val2.My_Type = Type_String) then
if (Operator = Equal) then
Local := Cmp (Val1.My_String, Val2.My_String);
elsif (Operator = Not_Equal) then
Local := not Cmp (Val1.My_String, Val2.My_String);
else
Copy (Val_Str, "Operateur chaine inconnu");
raise Type_Conflict;
end if;
Copy (Val_Str, Val1.My_String & " ");
Copy (Val_Str, Val_Str & Convert (Operator) & " ");
Copy (Val_Str, Val_Str & Val2.My_String);
Copy (Val_Str, Val_Str & " -> ");
else
Copy (Val_Str,
"Operation binaire booleenne avec operandes incompatibles");
raise Type_Conflict;
end if;
Verify_Print (Val_Str & Convert (Local));
Verify_New_Line;
return Local;
exception
when Type_Conflict =>
Print (Val_Str & " -> Type_Conflict");
Print_New_Line;
return False;
raise;
when others =>
Print (Val_Str & " -> Exception non traitee");
Print_New_Line;
raise;
end Op;
----------------------------------------------------------------------------
function Op (Operator : Lex.Token; Val1, Val2 : Var_Value) return Integer is
Val_Str : Var_String;
Local : Integer;
begin
if Verify_Type (Val1, Type_Integer) and then
Verify_Type (Val2, Type_Integer) then
if (Operator = Plus) then
Local := (Val1.My_Integer + Val2.My_Integer);
elsif (Operator = Minus) then
Local := (Val1.My_Integer - Val2.My_Integer);
elsif (Operator = Cross) then
Local := (Val1.My_Integer * Val2.My_Integer);
elsif (Operator = Slash) then
Local := (Val1.My_Integer / Val2.My_Integer);
else
Copy (Val_Str, "Operateur entier inconnu");
raise Type_Conflict;
end if;
Copy (Val_Str, Convert (Val1.My_Integer) & " ");
Copy (Val_Str, Val_Str & Convert (Operator) & " ");
Copy (Val_Str, Val_Str & Convert (Val2.My_Integer));
Copy (Val_Str, Val_Str & " -> ");
else
Copy (Val_Str,
"Operation binaire entiere avec operandes incompatibles");
raise Type_Conflict;
end if;
Verify_Print (Val_Str & Convert (Local));
Verify_New_Line;
return Local;
exception
when Type_Conflict =>
Print (Val_Str & " -> Type_Conflict");
Print_New_Line;
return 0;
raise;
when others =>
Print (Val_Str & " -> Exception non traitee");
Print_New_Line;
raise;
end Op;
----------------------------------------------------------------------------
function Op (Operator : Lex.Token; Val1, Val2 : Var_Value)
return Var_String is
Val_Str : Var_String;
Local : Var_String;
begin
if Verify_Type (Val1, Type_String) and then
Verify_Type (Val2, Type_String) then
if (Operator = Coma) then
Copy (Local, Val1.My_String & " & " & Val2.My_String);
else
Copy (Val_Str, "Operateur chaine inconnu");
raise Type_Conflict;
end if;
Copy (Val_Str, Val1.My_String & " ");
Copy (Val_Str, Val_Str & Convert (Operator) & " ");
Copy (Val_Str, Val_Str & Val2.My_String);
Copy (Val_Str, Val_Str & " -> ");
else
Copy (Val_Str,
"Operation binaire chaine avec operandes incompatibles");
raise Type_Conflict;
end if;
Verify_Print (Val_Str & Convert (Local));
Verify_New_Line;
return Local;
exception
when Type_Conflict =>
Print (Val_Str & " -> Type_Conflict");
Print_New_Line;
return Value (" _? , _? ");
raise;
when others =>
Print (Val_Str & " -> Exception non traitee");
Print_New_Line;
raise;
end Op;
----------------------------------------------------------------------------
end Our_Value;
nblk1=24
nid=8
hdr6=30
[0x00] rec0=1d rec1=00 rec2=01 rec3=03a
[0x01] rec0=1f rec1=00 rec2=15 rec3=006
[0x02] rec0=17 rec1=00 rec2=16 rec3=032
[0x03] rec0=1c rec1=00 rec2=1a rec3=000
[0x04] rec0=02 rec1=00 rec2=0a rec3=02c
[0x05] rec0=20 rec1=00 rec2=1b rec3=052
[0x06] rec0=1b rec1=00 rec2=22 rec3=008
[0x07] rec0=21 rec1=00 rec2=13 rec3=01a
[0x08] rec0=25 rec1=00 rec2=0d rec3=000
[0x09] rec0=1e rec1=00 rec2=0f rec3=038
[0x0a] rec0=24 rec1=00 rec2=0c rec3=04c
[0x0b] rec0=22 rec1=00 rec2=0b rec3=034
[0x0c] rec0=26 rec1=00 rec2=17 rec3=026
[0x0d] rec0=13 rec1=00 rec2=24 rec3=048
[0x0e] rec0=1f rec1=00 rec2=12 rec3=050
[0x0f] rec0=0f rec1=00 rec2=1f rec3=00c
[0x10] rec0=20 rec1=00 rec2=03 rec3=02c
[0x11] rec0=1c rec1=00 rec2=20 rec3=02a
[0x12] rec0=1b rec1=00 rec2=1e rec3=022
[0x13] rec0=1e rec1=00 rec2=23 rec3=05e
[0x14] rec0=1d rec1=00 rec2=02 rec3=074
[0x15] rec0=23 rec1=00 rec2=1d rec3=012
[0x16] rec0=1b rec1=00 rec2=10 rec3=00a
[0x17] rec0=14 rec1=00 rec2=14 rec3=000
[0x18] rec0=20 rec1=00 rec2=14 rec3=004
[0x19] rec0=1f rec1=00 rec2=10 rec3=01a
[0x1a] rec0=11 rec1=00 rec2=1e rec3=000
[0x1b] rec0=20 rec1=00 rec2=0a rec3=020
[0x1c] rec0=05 rec1=00 rec2=15 rec3=000
[0x1d] rec0=1b rec1=00 rec2=0c rec3=034
[0x1e] rec0=1b rec1=00 rec2=02 rec3=000
[0x1f] rec0=05 rec1=00 rec2=22 rec3=000
[0x20] rec0=8c rec1=00 rec2=00 rec3=000
[0x21] rec0=00 rec1=00 rec2=15 rec3=7cf
[0x22] rec0=00 rec1=00 rec2=00 rec3=000
[0x23] rec0=00 rec1=00 rec2=00 rec3=021
tail 0x21546833e865b5ee044d4 0x42a00088462060003
Free Block Chain:
0x8: 0000 00 05 00 2e 00 09 20 20 20 20 62 65 67 69 6e 09 ┆ . begin ┆
0x5: 0000 00 0e 01 91 80 1d 20 20 20 20 20 20 20 20 20 77 ┆ w┆
0xe: 0000 00 04 00 1d 80 0d 79 70 65 5f 43 6f 6e 66 6c 69 ┆ ype_Confli┆
0x4: 0000 00 11 03 fc 80 06 6e 64 20 69 66 3b 06 00 0e 20 ┆ nd if; ┆
0x11: 0000 00 06 01 ce 00 00 00 00 0c 20 20 20 20 20 20 20 ┆ ┆
0x6: 0000 00 18 03 fc 80 34 6f 6d 6d 75 74 65 20 28 56 61 ┆ 4ommute (Va┆
0x18: 0000 00 07 03 fc 80 2d 28 22 20 75 6e 65 20 63 68 61 ┆ -(" une cha┆
0x7: 0000 00 19 03 fc 80 3a 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ┆ :----------┆
0x19: 0000 00 09 03 fc 80 05 65 21 22 29 3b 05 00 1f 20 20 ┆ e!"); ┆
0x9: 0000 00 21 03 fc 80 1a 77 68 65 6e 20 42 6f 6f 6c 65 ┆ ! when Boole┆
0x21: 0000 00 1c 03 fc 00 35 20 20 20 20 20 20 20 20 20 20 ┆ 5 ┆
0x1c: 0000 00 00 03 f9 80 24 20 4f 70 5f 43 6f 6d 6d 75 74 ┆ $ Op_Commut┆