|
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: 26624 (0x6800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Block_Class, seg_03930b, seg_0393ff, seg_039542
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Boolean_Class;
with Bounded_String;
with Errors;
with Pen_Class;
with String_Class;
with Trace;
with Turtle_Class;
with Unparser;
package body Block_Class is
type Unary_Message is (Nul, Valeur, En_Texte);
type One_Argument_Message is (Nul, Tant_Que_Vrai, Tant_Que_Faux);
procedure Create_Program_Block is
begin
Trace.Display ("block_class.create_program_block");
Blocks (0).Free := False;
Blocks (0).Enclosing := 0;
Current_Block := 0;
end Create_Program_Block;
function Create return Object.Reference is
Class_Id : Object.Class := Object.Bloc;
Obj : Object.Reference := Object.Void_Reference;
begin
Trace.Display ("block_class.create");
for I in Block_Map'Range loop
if Blocks (I).Free then
Blocks (I).Free := False;
Blocks (I).Enclosing := Current_Block;
Current_Block := I;
Obj := (Object.Create (Class_Id, Integer (I)));
exit;
end if;
end loop;
if Object.Equal (Obj, Object.Void_Reference) then
raise Errors.Max_Block_Number_Exceeded;
else
return Obj;
end if;
end Create;
procedure Unparse (The_Block : Object.Reference) is
Index : Size := Size (Object.Get_Id (The_Block));
begin
if not Message.Is_Empty (Blocks (Index).Keywords) then
Unparser.Put ("Avec ");
Message.Init (Blocks (Index).Keywords);
Message.Init (Blocks (Index).Arguments);
while not Message.Done (Blocks (Index).Keywords) loop
Unparser.Put (Message.Value (Blocks (Index).Keywords));
Unparser.Put (" ");
Unparser.Put (Message.Value (Blocks (Index).Arguments));
Unparser.Put (" ");
Message.Next (Blocks (Index).Keywords);
Message.Next (Blocks (Index).Arguments);
end loop;
Unparser.Put (".");
Unparser.New_Line;
end if;
Trace.Display ("fin unparse block_class");
end Unparse;
procedure Close is
begin
Trace.Display ("block_class.close");
Current_Block := Blocks (Current_Block).Enclosing;
end Close;
procedure New_Symbols_Table is
begin
Trace.Display ("block_class.new_symbols_table");
Symbols.Create_Map (Blocks (Current_Block).Local_Symb);
end New_Symbols_Table;
function Table_Created return Boolean is
begin
Trace.Display ("block_class.table_created");
return (not Symbols.Is_Nil (Blocks (Current_Block).Local_Symb));
end Table_Created;
procedure Set_Predefined_Identifiers is
Iterator : Custom.Predefined_Id;
Predef_Id : Scanner.Lexeme;
use Custom;
begin
Iterator := Custom.Predefined_Id'First;
loop
Predef_Id := Bounded_String.Value
(Custom.Predefined_Id'Image (Iterator),
Custom.String_Max_Length);
case Iterator is
when Custom.Tortue =>
Symbols.Insert (Predef_Id,
Blocks (Current_Block).Local_Symb,
Turtle_Class.Create);
when Custom.Stylo =>
Symbols.Insert (Predef_Id,
Blocks (Current_Block).Local_Symb,
Pen_Class.Create);
when Custom.Vrai =>
Symbols.Insert (Predef_Id,
Blocks (Current_Block).Local_Symb,
Boolean_Class.True);
when Custom.Faux =>
Symbols.Insert (Predef_Id,
Blocks (Current_Block).Local_Symb,
Boolean_Class.False);
when Custom.Vide =>
Symbols.Insert (Predef_Id,
Blocks (Current_Block).Local_Symb,
Object.Void_Reference);
when Custom.Valeur =>
null;
end case;
exit when Iterator = (Custom.Predefined_Id'Last);
Iterator := Custom.Predefined_Id'Succ (Iterator);
end loop;
end Set_Predefined_Identifiers;
procedure Init_Symbol (The_Symbol : Scanner.Lexeme) is
Seek_Block : Size;
Found : Boolean := False;
Obj : Object.Reference;
begin
Trace.Display ("block_class.init_symbol");
Seek_Block := Current_Block;
loop
if not Symbols.Is_Nil (Blocks (Seek_Block).Local_Symb) then
Symbols.Find
(The_Symbol, Blocks (Seek_Block).Local_Symb, Obj, Found);
end if;
exit when Found or Seek_Block = 0;
Seek_Block := Blocks (Seek_Block).Enclosing;
end loop;
if not Found then
Symbols.Insert (The_Symbol, Blocks (Current_Block).Local_Symb,
Object.Void_Reference);
end if;
end Init_Symbol;
procedure Set_Value (The_Symbol : Scanner.Lexeme;
The_Value : Object.Reference) is
Seek_Block : Size;
Found : Boolean := False;
Obj : Object.Reference;
begin
Trace.Display ("block_class.set_value");
Seek_Block := Current_Block;
loop
if not Symbols.Is_Nil (Blocks (Seek_Block).Local_Symb) then
Symbols.Find
(The_Symbol, Blocks (Seek_Block).Local_Symb, Obj, Found);
if Found then
Symbols.Insert
(The_Symbol, Blocks (Seek_Block).Local_Symb, The_Value);
exit;
end if;
end if;
if Seek_Block = 0 then
raise Errors.Set_Value_To_Undefined_Identifier;
else
Seek_Block := Blocks (Seek_Block).Enclosing;
end if;
end loop;
end Set_Value;
procedure Set_Argument_Value (The_Symbol : Scanner.Lexeme;
The_Value : Object.Reference;
In_Block : in out Block_Def) is
begin
Trace.Display ("block_class.set_argument_value");
Symbols.Insert (The_Symbol, In_Block.Local_Symb, The_Value);
end Set_Argument_Value;
function Get_Value (The_Symbol : Scanner.Lexeme) return Object.Reference is
Seek_Block : Size;
Found : Boolean := False;
Obj : Object.Reference;
begin
Trace.Display ("block_class.get_value");
Seek_Block := Current_Block;
loop
if not Symbols.Is_Nil (Blocks (Seek_Block).Local_Symb) then
Symbols.Find
(The_Symbol, Blocks (Seek_Block).Local_Symb, Obj, Found);
if Found then
return Obj;
exit;
end if;
end if;
if Seek_Block = 0 then
raise Errors.Get_Value_Of_Undefined_Identifier;
else
Seek_Block := Blocks (Seek_Block).Enclosing;
end if;
end loop;
end Get_Value;
procedure New_Arg_List is
begin
Trace.Display ("block_class.new_arg_list");
Message.Free (Blocks (Current_Block).Keywords);
Message.Free (Blocks (Current_Block).Arguments);
end New_Arg_List;
procedure Set_Node (For_Block : Object.Reference; The_Node : Block.Node) is
Index : Size;
begin
Index := Size (Object.Get_Id (For_Block));
Blocks (Index).Parse_Node := The_Node;
end Set_Node;
procedure Set_Keyword (The_Keyword : Scanner.Lexeme) is
begin
Trace.Display ("block_class.set_keyword");
Message.Init (Blocks (Current_Block).Keywords);
while not Message.Done (Blocks (Current_Block).Keywords) loop
if (Bounded_String.Image
(Message.Value (Blocks (Current_Block).Keywords)) =
Bounded_String.Image (The_Keyword)) and
(Bounded_String.Image
(Message.Value (Blocks (Current_Block).Keywords)) /=
"VALEUR:") then
raise Errors.Several_Arguments_With_Same_Name;
else
Message.Next (Blocks (Current_Block).Keywords);
end if;
end loop;
Message.Insert (The_Keyword, Blocks (Current_Block).Keywords);
end Set_Keyword;
procedure Set_Argument (The_Argument : Scanner.Lexeme) is
begin
Trace.Display ("block_class.set_argument");
Message.Init (Blocks (Current_Block).Arguments);
while not Message.Done (Blocks (Current_Block).Arguments) loop
if (Bounded_String.Image (Message.Value
(Blocks (Current_Block).Arguments)) =
Bounded_String.Image (The_Argument)) then
raise Errors.Multiply_Defined_Argument;
else
Message.Next (Blocks (Current_Block).Arguments);
end if;
end loop;
Message.Insert (The_Argument, Blocks (Current_Block).Arguments);
Symbols.Insert (The_Argument, Blocks (Current_Block).Local_Symb,
Object.Void_Reference);
end Set_Argument;
function Convert_To_Unary
(The_Message : Scanner.Lexeme) return Unary_Message is
begin
if Bounded_String.Image (The_Message) = "VALEUR" then
return Valeur;
elsif Bounded_String.Image (The_Message) = "EN_TEXTE" then
return En_Texte;
else
return Nul;
end if;
end Convert_To_Unary;
function Convert_To_One_Arg_Msg
(The_Message : Scanner.Lexeme) return One_Argument_Message is
begin
if Bounded_String.Image (The_Message) = "TANT_QUE_VRAI:" then
return Tant_Que_Vrai;
elsif Bounded_String.Image (The_Message) = "TANT_QUE_FAUX:" then
return Tant_Que_Faux;
else
return Nul;
end if;
end Convert_To_One_Arg_Msg;
function Matching_Keyword
(Msg_Kw : Message.Selector; Check_Block : Block_Def)
return Boolean is
begin
return (Bounded_String.Image (Message.Value (Msg_Kw)) =
Bounded_String.Image (Message.Value (Check_Block.Keywords))) or
(Bounded_String.Image (Message.Value (Msg_Kw)) = "VALEUR:");
end Matching_Keyword;
function Same_Selector_Length
(Msg_Kw : Message.Selector; Check_Block : Block_Def)
return Boolean is
begin
return Message.Arg_Number (Msg_Kw) =
Message.Arg_Number (Check_Block.Keywords);
end Same_Selector_Length;
procedure Invalid_Arg_Number
(Msg_Kw : Message.Selector; Check_Block : Block_Def) is
begin
if Message.Arg_Number (Msg_Kw) <
Message.Arg_Number (Check_Block.Keywords) then
raise Errors.Bloc_Msg_With_Not_Enough_Arguments;
else
raise Errors.Bloc_Msg_With_Too_Many_Arguments;
end if;
end Invalid_Arg_Number;
procedure Get_First_Keyword (Msg_Kw : in out Message.Selector;
Msg_Arg : in out Parameters.List;
Check_Block : in out Block_Def) is
begin
Message.Init (Msg_Kw);
Parameters.Init (Msg_Arg);
Message.Init (Check_Block.Keywords);
Message.Init (Check_Block.Arguments);
end Get_First_Keyword;
procedure Get_Next_Keyword (Msg_Kw : in out Message.Selector;
Msg_Arg : in out Parameters.List;
Check_Block : in out Block_Def) is
begin
Message.Next (Msg_Kw);
Parameters.Next (Msg_Arg);
Message.Next (Check_Block.Keywords);
Message.Next (Check_Block.Arguments);
end Get_Next_Keyword;
procedure Check_Tantque_Msg (Msg_Kw : in out Message.Selector;
Msg_Arg : in out Parameters.List;
Check_Block : in out Size;
Is_It : in out Boolean;
Back_Object : out Object.Reference) is
One_Arg_Selector : One_Argument_Message;
Interpret_Yourself : Scanner.Lexeme :=
Bounded_String.Value ("VALEUR", Custom.String_Max_Length);
Result : Object.Reference;
Is_Tqvrai : Boolean;
Save_Current_Block : Size;
begin
Trace.Display ("block_class.Check_Tantque_Msg");
Is_It := False;
if Message.Arg_Number (Msg_Kw) = 1 then
One_Arg_Selector := Convert_To_One_Arg_Msg (Message.Value (Msg_Kw)); case One_Arg_Selector is
when Tant_Que_Vrai =>
Is_It := True;
Is_Tqvrai := True;
when Tant_Que_Faux =>
Is_It := True;
Is_Tqvrai := False;
when Nul =>
null;
end case;
if Is_It then
loop
Save_Current_Block := Current_Block;
Current_Block := Check_Block;
Result := Block.Interpret (Blocks (Check_Block).Parse_Node);
Current_Block := Save_Current_Block;
case Object.Get_Class (Result) is
when Object.Booleen =>
exit when (Is_Tqvrai and
Object.Equal (Result,
Boolean_Class.False)) or
((not Is_Tqvrai) and
Object.Equal (Result,
Boolean_Class.True));
case Object.Get_Class
(Parameters.Value (Msg_Arg)) is
when Object.Bloc =>
Back_Object :=
Send (Parameters.Value (Msg_Arg),
Interpret_Yourself);
when others =>
raise
Errors.
Block_Argument_Required_For_Tantque_Msg;
end case;
when others =>
raise Errors.Tantque_Msg_To_Non_Boolean_Block;
end case;
end loop;
end if;
else
Is_It := False;
end if;
end Check_Tantque_Msg;
function Send (To_Object : Object.Reference; The_Message : Scanner.Lexeme)
return Object.Reference is
Current_Message : Unary_Message := Nul;
Index, Save_Current_Block : Size;
Current_Entexte : Scanner.Lexeme;
begin
Trace.Display ("block_class.send (message unaire)");
Current_Message := Convert_To_Unary (The_Message);
case Current_Message is
when Nul =>
raise Errors.Unknown_Message_For_Block;
when Valeur =>
Index := Size (Object.Get_Id (To_Object));
if (Message.Is_Empty (Blocks (Index).Keywords)) then
Save_Current_Block := Current_Block;
Current_Block := Index;
return Block.Interpret (Blocks (Index).Parse_Node);
Current_Block := Save_Current_Block;
else
raise Errors.Unary_Message_To_Block_With_Arguments;
end if;
when En_Texte =>
Bounded_String.Append
(Current_Entexte, Bounded_String.Value
("Bloc no", Custom.String_Max_Length));
Bounded_String.Append
(Current_Entexte, Integer'Image (Object.Get_Id (To_Object)));
return String_Class.Create (Current_Entexte);
end case;
return To_Object;
end Send;
procedure Send (To_Object : Object.Reference;
The_Message : in out Message.Selector;
With_Arguments : in out Parameters.List;
Back_Object : out Object.Reference) is
Index, Save_Current_Block : Size;
Result : Object.Reference;
It_Is : Boolean;
begin
Trace.Display ("block_class.send (message a mots cles)");
Index := Size (Object.Get_Id (To_Object));
Get_First_Keyword (The_Message, With_Arguments, Blocks (Index));
Check_Tantque_Msg (The_Message, With_Arguments, Index, It_Is, Result);
if It_Is then
Back_Object := Result;
else
if Same_Selector_Length (The_Message, Blocks (Index)) then
while not Message.Done (The_Message) loop
if Matching_Keyword (The_Message, Blocks (Index)) then
Set_Argument_Value
(Message.Value (Blocks (Index).Arguments),
Parameters.Value (With_Arguments), Blocks (Index));
else
raise Errors.Inconsistent_Msg_Selector_For_Block;
end if;
Get_Next_Keyword
(The_Message, With_Arguments, Blocks (Index));
end loop;
Save_Current_Block := Current_Block;
Current_Block := Index;
Back_Object := Block.Interpret (Blocks (Index).Parse_Node);
Current_Block := Save_Current_Block;
else
Invalid_Arg_Number (The_Message, Blocks (Index));
end if;
end if;
end Send;
end Block_Class;
nblk1=19
nid=12
hdr6=2c
[0x00] rec0=22 rec1=00 rec2=01 rec3=00c
[0x01] rec0=00 rec1=00 rec2=08 rec3=018
[0x02] rec0=18 rec1=00 rec2=16 rec3=020
[0x03] rec0=1f rec1=00 rec2=13 rec3=04e
[0x04] rec0=14 rec1=00 rec2=0f rec3=048
[0x05] rec0=18 rec1=00 rec2=02 rec3=042
[0x06] rec0=0b rec1=00 rec2=17 rec3=044
[0x07] rec0=1a rec1=00 rec2=15 rec3=06e
[0x08] rec0=17 rec1=00 rec2=04 rec3=026
[0x09] rec0=1c rec1=00 rec2=11 rec3=030
[0x0a] rec0=15 rec1=00 rec2=03 rec3=048
[0x0b] rec0=1a rec1=00 rec2=14 rec3=064
[0x0c] rec0=1b rec1=00 rec2=06 rec3=012
[0x0d] rec0=00 rec1=00 rec2=07 rec3=014
[0x0e] rec0=18 rec1=00 rec2=0b rec3=02c
[0x0f] rec0=16 rec1=00 rec2=10 rec3=002
[0x10] rec0=0e rec1=00 rec2=05 rec3=022
[0x11] rec0=10 rec1=00 rec2=0d rec3=020
[0x12] rec0=1a rec1=00 rec2=09 rec3=00c
[0x13] rec0=13 rec1=00 rec2=19 rec3=02e
[0x14] rec0=16 rec1=00 rec2=0a rec3=034
[0x15] rec0=14 rec1=00 rec2=0c rec3=000
[0x16] rec0=10 rec1=00 rec2=0c rec3=000
[0x17] rec0=00 rec1=00 rec2=00 rec3=000
[0x18] rec0=00 rec1=00 rec2=00 rec3=000
tail 0x2153234f684ec4caca95f 0x42a00088462060003
Free Block Chain:
0x12: 0000 00 0e 03 fc 80 13 62 6a 65 63 74 2e 52 65 66 65 ┆ bject.Refe┆
0xe: 0000 00 18 00 28 80 25 20 20 20 20 20 20 20 20 20 20 ┆ ( % ┆
0x18: 0000 00 00 01 79 80 35 50 75 74 5f 4c 69 6e 65 20 28 ┆ y 5Put_Line (┆