|
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: 38912 (0x9800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Terminal, seg_05c1cd
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Xlbt_Basic, Xlbt_Event, Xlbt_Window, Xlbt_Font, Xlbt_Text,
Xlbt_Key, Xlbt_String, Xlbt_Arithmetic, Xlbt_Gc, Xlbt_Hint;
use Xlbt_Basic, Xlbt_Event, Xlbt_Window, Xlbt_Font, Xlbt_Text,
Xlbt_Key, Xlbt_String, Xlbt_Arithmetic, Xlbt_Gc, Xlbt_Hint;
with Xlbp_Event, Xlbp_Display, Xlbp_Window, Xlbp_Font, Xlbp_Key,
Xlbp_Text, Xlbp_Sync, Xlbp_Gc, Xlbp_Graphics, Xlbp_Hint, Text_Io;
use Xlbp_Event, Xlbp_Display, Xlbp_Window, Xlbp_Font, Xlbp_Key,
Xlbp_Text, Xlbp_Sync, Xlbp_Gc, Xlbp_Graphics, Xlbp_Hint, Text_Io;
with Text_Io;
package body Terminal is
task type Wait_Event is
entry Go (H : in Handle);
end Wait_Event;
subtype S20 is String (1 .. 20);
Max_Term : constant Integer := 20;
Last_Term : Integer := 0;
Noms : array (1 .. Max_Term) of S20 := (others => (others => ' '));
type T_W_Acc is access Wait_Event;
type Font_Type_Type is (Small, Medium, Large);
type Font_Record_Type is
record
Font : X_Font_Struct;
Width : S_Short;
Height : S_Short;
end record;
Null_Font_Record : constant Font_Record_Type :=
(Font => None_X_Font_Struct, Width => 0, Height => 0);
type Font_Array_Type is array (Font_Type_Type) of Font_Record_Type;
Null_Font_Array : constant Font_Array_Type := (others => Null_Font_Record);
type Enreg_T;
type Enreg_P is access Enreg_T;
type Enreg_T is
record
Next, Prev : Enreg_P;
Terminal : Handle;
C : Character;
X, Y : Tcoordonnees;
Blink : Boolean;
end record;
task type Buffer_Task is
entry Put (Terminal : in Handle;
C : in Character;
X, Y : in Tcoordonnees;
Blink : in Boolean);
entry Get (Terminal : in Handle;
C : out Character;
X, Y : out Tcoordonnees;
Blink : out Boolean;
Succes : out Boolean);
entry Stop;
end Buffer_Task;
type T_B_Acc is access Buffer_Task;
type Objet is
record
Buffer : T_B_Acc;
First_F, First_B, Last_B : Enreg_P;
No : Integer;
Display : X_Display;
Screen : X_Screen_Number;
Root_Window, Main_Window : X_Window;
Current_Font : Font_Record_Type;
Fonts : Font_Array_Type;
Graphic_Context : X_Gc;
T : T_W_Acc;
Stop : Boolean;
X_Request_Count : Natural;
Next, Prev : Handle;
end record; Null_Objet : constant Objet := (Buffer => null,
First_F => null,
First_B => null,
Last_B => null,
No => 0,
Display => None_X_Display,
Screen => None_X_Screen_Number,
Root_Window => None_X_Window,
Main_Window => None_X_Window,
Current_Font => Null_Font_Record,
Fonts => Null_Font_Array,
Graphic_Context => None_X_Gc,
T => null,
Stop => False,
X_Request_Count => 0,
Next => null,
Prev => null);
First_Busy : Handle := null;
First_Free : Handle := null;
Max_No_Flushed_Requests : constant Natural := 1;
Black, White : X_Pixel;
Width : constant Natural := 80;
The_String : constant String (1 .. Width) := (others => ' ');
Loc_Event_Mask : constant X_Event_Mask := All_Event_Mask;
Nb_Term : Integer := 0;
procedure Flush_If_Needed (H : in Handle) is
begin
H.X_Request_Count := H.X_Request_Count + 1;
if H.X_Request_Count >= Max_No_Flushed_Requests then
X_Sync (H.Display, False);
H.X_Request_Count := 0;
end if;
end Flush_If_Needed;
procedure Video_Normale (H : in Handle) is
begin
X_Set_Foreground (H.Display, H.Graphic_Context, Black);
X_Set_Background (H.Display, H.Graphic_Context, White);
end Video_Normale;
procedure Video_Inverse (H : in Handle) is
begin
X_Set_Foreground (H.Display, H.Graphic_Context, White);
X_Set_Background (H.Display, H.Graphic_Context, Black);
end Video_Inverse;
procedure Envoyer (Terminal : in Handle;
C : in Character;
X, Y : in Tcoordonnees;
Blink : in Boolean := False) is
My_X_String : X_String (1 .. 1);
C_P : X_Character;
begin
if Blink then
Video_Inverse (Terminal);
end if;
C_P := X_Character'Val (Character'Pos (C));
My_X_String (1) := C_P;
X_Draw_Image_String (Display => Terminal.Display,
Drawable => Terminal.Main_Window.Drawable,
Gc => Terminal.Graphic_Context,
X => Terminal.Current_Font.Width * S_Short (X - 1),
Y => Terminal.Current_Font.Height * S_Short (Y),
Text => My_X_String);
Flush_If_Needed (Terminal);
if Blink then
Video_Normale (Terminal);
end if;
end Envoyer;
task body Wait_Event is
Event : X_Event;
Terminal : Handle;
Rc, C : Character;
X, Y : Tcoordonnees;
Succes, Blink : Boolean;
Buffer : X_String (1 .. 10);
Result : S_Natural;
Key_Symbol : X_Key_Sym;
Status : X_Compose_Status;
type State_Type is (Wait_Press, Wait_Release, Wait_Read);
State : State_Type := Wait_Press;
begin
accept Go (H : in Handle) do
Terminal := H;
Text_Io.Put_Line ("Creation term " & Integer'Image (Terminal.No));
end Go;
while not Terminal.Stop loop
if Terminal.First_B /= null then
Terminal.Buffer.Get (Terminal => Terminal,
C => Rc,
X => X,
Y => Y,
Blink => Blink,
Succes => Succes);
Envoyer (Terminal => Terminal,
C => Rc,
X => X,
Y => Y,
Blink => Blink);
end if;
if (X_Pending (Terminal.Display) > 0) then
X_Next_Event (Terminal.Display, Event);
--Text_Io.Put_Line ("Term = " & Integer'Image (Terminal.No) &
-- " Event = " & X_Event_Code'Image (Event.Kind));
case Event.Kind is
when Key_Press =>
--if State = Wait_Press then
begin
X_Lookup_String (Event, Buffer, Result,
Key_Symbol, Status);
C := To_String (Buffer (1 .. Result)) (1);
Envoyer_Caractere (C => C, No => Terminal.No);
--State := Wait_Release;
exception
when others =>
null;
end;
--end if;
-- when Key_Release =>
-- if State = Wait_Release then
-- State := Wait_Read;
-- --Text_Io.Put_Line
-- -- ("****** Term = " &
-- -- Integer'Image (Terminal.No) & " Event = " &
-- -- X_Event_Code'Image (Event.Kind));
-- Envoyer_Caractere (C => C, No => Terminal.No);
-- State := Wait_Press;
-- end if;
when others =>
null;
end case;
elsif Terminal.First_B = null then
delay 0.1;
end if;
end loop;
exception
when others =>
Text_Io.Put_Line ("Exception wait_event" &
Integer'Image (Terminal.No));
end Wait_Event;
function Get_Handle return Handle is
Loc_Handle : Handle := First_Free;
begin
if First_Free /= null then
First_Free := First_Free.Next;
else
Loc_Handle := new Objet;
end if;
Loc_Handle.all := Null_Objet;
Loc_Handle.T := new Wait_Event;
Loc_Handle.Buffer := new Buffer_Task;
return Loc_Handle;
end Get_Handle;
procedure Put_Handle (H : in out Handle) is
begin
H.Next := First_Free;
First_Free := H;
end Put_Handle;
procedure Set_Window_Manager_Hints (H : Handle;
Title : String;
X, Y : S_Short;
Width, Height : U_Short_Positive) is
Success : X_Status;
Size_Hints : X_Size_Hints;
begin
Size_Hints.Flags (U_S_Position) := True;
Size_Hints.Flags (U_S_Size) := True;
Size_Hints.Width := S_Long (Width);
Size_Hints.Height := S_Long (Height);
Size_Hints.X := S_Long (X);
Size_Hints.Y := S_Long (Y);
X_Set_Wm_Properties (Display => H.Display,
Window => H.Main_Window,
Window_Name => To_X_String (Title),
Icon_Name => To_X_String (Title),
Arg_V => (1 .. 0 => null),
Normal => Size_Hints,
Wm => None_X_Wm_Hints,
Class => None_X_Class_Hint,
Status => Success);
end Set_Window_Manager_Hints;
procedure Create_Window (H : in Handle;
Title : String;
X, Y : S_Short;
Width, Height : U_Short_Positive) is
Xswa : X_Set_Window_Attributes;
begin
Xswa.Event_Mask := Loc_Event_Mask;
Xswa.Background_Pixel := White;
Xswa.Border_Pixel := Black;
H.Main_Window :=
X_Create_Window
(Display => H.Display,
Parent => H.Root_Window,
X => X,
Y => Y,
Width => Width,
Height => Height,
Border_Width => 0,
Depth => X_Default_Depth (H.Display, H.Screen),
Class => Input_Output,
Visual => X_Default_Visual (H.Display, H.Screen),
Values_Mask =>
(Cw_Event_Mask | Cw_Back_Pixel | Cw_Border_Pixel => True,
others => False),
Values => Xswa);
Set_Window_Manager_Hints (H, Title, X, Y, Width, Height);
X_Map_Window (H.Display, H.Main_Window);
end Create_Window;
procedure Create_Graphic_Context (H : in Handle) is
Xgcv : X_Gc_Values;
begin
H.Graphic_Context := X_Create_Gc
(H.Display, H.Main_Window.Drawable,
None_X_Gc_Components, None_X_Gc_Values);
Xgcv.Foreground := Black;
Xgcv.Background := White;
Xgcv.Line_Width := 1;
Xgcv.Cap_Style := Cap_Round;
Xgcv.Font := H.Current_Font.Font.Font_Id;
X_Change_Gc (H.Display, H.Graphic_Context,
(Gc_Line_Width | Gc_Cap_Style |
Gc_Foreground | Gc_Background | Gc_Font => True,
others => False), Xgcv);
end Create_Graphic_Context;
procedure Load_The_Fonts (H : in Handle) is
begin
H.Fonts (Small).Font :=
X_Load_Query_Font (Display => H.Display,
Name => To_X_String ("rom10"));
H.Fonts (Medium).Font :=
X_Load_Query_Font (Display => H.Display,
Name => To_X_String ("rom14"));
H.Fonts (Large).Font :=
X_Load_Query_Font (Display => H.Display,
Name => To_X_String ("rom28"));
for Ft in Font_Type_Type loop
H.Fonts (Ft).Width := S_Short (H.Fonts (Ft).Font.Max_Bounds.Width);
H.Fonts (Ft).Height := S_Short (H.Fonts (Ft).Font.Ascent +
H.Fonts (Ft).Font.Descent);
end loop;
end Load_The_Fonts;
function Creer (Col : in Tcoordonnees := Max_Col;
Lin : in Tcoordonnees := Max_Lin;
No : in Integer) return Handle is
Title : constant String := "BT/BP";
Left, Right : S_Short := 100;
Width, Height : U_Short_Positive := 800;
The_Name : constant X_String :=
X_Display_Name (To_X_String (Noms (No)));
Error : X_Error_String;
Loc_Handle : Handle := Get_Handle;
begin
Loc_Handle.No := No;
X_Open_Display (The_Name, Loc_Handle.Display, Error);
if Loc_Handle.Display = None_X_Display then
Text_Io.Put_Line ("Fatal error, " & To_String (Err (Error)));
else
Nb_Term := Nb_Term + 1;
Loc_Handle.Screen := X_Default_Screen (Loc_Handle.Display);
Loc_Handle.Root_Window :=
X_Root_Window (Loc_Handle.Display, Loc_Handle.Screen);
Black := X_Black_Pixel (Loc_Handle.Display, Loc_Handle.Screen);
White := X_White_Pixel (Loc_Handle.Display, Loc_Handle.Screen);
Load_The_Fonts (Loc_Handle);
Loc_Handle.Current_Font := Loc_Handle.Fonts (Small);
Width := U_Short_Positive (Loc_Handle.Current_Font.Width) *
U_Short_Positive (Col);
Height := U_Short_Positive (Loc_Handle.Current_Font.Height) *
U_Short_Positive (Lin);
Create_Window (Loc_Handle, Title, Left, Right, Width, Height);
Create_Graphic_Context (Loc_Handle);
Video_Normale (Loc_Handle);
if First_Busy /= null then
First_Busy.Prev := Loc_Handle;
end if;
Loc_Handle.Next := First_Busy;
First_Busy := Loc_Handle;
Loc_Handle.T.Go (Loc_Handle);
end if;
return Loc_Handle;
end Creer;
task body Buffer_Task is
Tc : Character;
E : Enreg_P := null;
function Get (Terminal : in Handle) return Enreg_P is
El : Enreg_P;
begin
if Terminal.First_F = null then
El := new Enreg_T;
else
El := Terminal.First_F;
Terminal.First_F := El.Next;
end if;
El.Prev := Terminal.Last_B;
El.Next := null;
if Terminal.Last_B /= null then
Terminal.Last_B.Next := El;
end if;
Terminal.Last_B := El;
if Terminal.First_B = null then
Terminal.First_B := El;
end if;
return El;
end Get;
procedure Put (Terminal : in Handle; El : in out Enreg_P) is
begin
if El.Next /= null then
if El.Prev /= null then
El.Prev.Next := El.Next;
El.Next.Prev := El.Prev;
else
Terminal.First_B := El.Next;
El.Next.Prev := null;
end if;
else
if El.Prev /= null then
Terminal.Last_B := El.Prev;
El.Prev.Next := null;
else
Terminal.First_B := null;
Terminal.Last_B := null;
end if;
end if;
El.Next := Terminal.First_F;
Terminal.First_F := El;
end Put;
begin
Ad_Vitam_Eternam:
loop
select
accept Put (Terminal : in Handle;
C : in Character;
X, Y : in Tcoordonnees;
Blink : in Boolean) do
E := Get (Terminal => Terminal);
E.Terminal := Terminal;
E.C := C;
E.X := X;
E.Y := Y;
E.Blink := Blink;
end Put;
or
accept Get (Terminal : in Handle;
C : out Character;
X, Y : out Tcoordonnees;
Blink : out Boolean;
Succes : out Boolean) do
C := 'a';
X := Tcoordonnees'Last;
Y := Tcoordonnees'Last;
Blink := False;
Succes := False;
E := Terminal.First_B;
Boucle_Cherche:
while E /= null loop
if E.Terminal = Terminal then
C := E.C;
Tc := E.C;
X := E.X;
Y := E.Y;
Blink := E.Blink;
Put (Terminal => Terminal, El => E);
Succes := True;
exit Boucle_Cherche;
end if;
E := E.Next;
end loop Boucle_Cherche;
end Get;
or
accept Stop;
exit Ad_Vitam_Eternam;
end select;
end loop Ad_Vitam_Eternam;
Text_Io.Put_Line ("Buffer_task : fin");
exception
when others =>
Text_Io.Put_Line ("Buffer_task : exception");
end Buffer_Task;
procedure Ecrire (Terminal : in Handle;
C : in Character;
X, Y : in Tcoordonnees;
Blink : in Boolean := False) is
begin
--Envoyer (Terminal => Terminal, C => C, X => X, Y => Y, Blink => Blink);
Terminal.Buffer.Put
(Terminal => Terminal, C => C, X => X, Y => Y, Blink => Blink);
end Ecrire;
procedure Fermer (Terminal : in out Handle) is
begin
Text_Io.Put_Line ("Fermeture term " & Integer'Image (Terminal.No));
Terminal.Stop := True;
Terminal.Buffer.Stop;
X_Close_Display (Terminal.Display);
if Terminal.Prev /= null then
if Terminal.Next /= null then
Terminal.Prev.Next := Terminal.Next;
Terminal.Next.Prev := Terminal.Prev;
else
Terminal.Prev.Next := null;
end if;
else
if Terminal.Next /= null then
Terminal.Next.Prev := null;
First_Busy := Terminal.Next;
else
First_Busy := null;
end if;
end if;
Put_Handle (H => Terminal);
Nb_Term := Nb_Term - 1;
--if Nb_Term = 0 then
-- Buffer_Task.Stop;
--end if;
end Fermer;
procedure Init_Configuration is
F : Text_Io.File_Type;
S : String (1 .. 100);
L : Natural;
begin
Text_Io.Open (File => F, Mode => Text_Io.In_File, Name => "liste_noms");
while not Text_Io.End_Of_File (File => F) loop
Text_Io.Get_Line (File => F, Item => S, Last => L);
Last_Term := Last_Term + 1;
Text_Io.Put_Line ("Lecture de " & S (1 .. L));
Noms (Last_Term) (1 .. L) := S (1 .. L);
end loop;
Text_Io.Close (File => F);
end Init_Configuration;
end Terminal;
nblk1=25
nid=12
hdr6=40
[0x00] rec0=17 rec1=00 rec2=01 rec3=028
[0x01] rec0=1b rec1=00 rec2=13 rec3=01c
[0x02] rec0=00 rec1=00 rec2=22 rec3=02c
[0x03] rec0=18 rec1=00 rec2=14 rec3=002
[0x04] rec0=02 rec1=00 rec2=0e rec3=070
[0x05] rec0=10 rec1=00 rec2=03 rec3=02e
[0x06] rec0=11 rec1=00 rec2=07 rec3=022
[0x07] rec0=19 rec1=00 rec2=1a rec3=05c
[0x08] rec0=1a rec1=00 rec2=23 rec3=02e
[0x09] rec0=15 rec1=00 rec2=20 rec3=052
[0x0a] rec0=00 rec1=00 rec2=16 rec3=030
[0x0b] rec0=14 rec1=00 rec2=1c rec3=01c
[0x0c] rec0=1b rec1=00 rec2=04 rec3=032
[0x0d] rec0=00 rec1=00 rec2=1e rec3=006
[0x0e] rec0=18 rec1=00 rec2=0f rec3=00e
[0x0f] rec0=03 rec1=00 rec2=06 rec3=04e
[0x10] rec0=17 rec1=00 rec2=10 rec3=01c
[0x11] rec0=00 rec1=00 rec2=17 rec3=024
[0x12] rec0=17 rec1=00 rec2=1f rec3=046
[0x13] rec0=01 rec1=00 rec2=05 rec3=006
[0x14] rec0=15 rec1=00 rec2=0a rec3=05e
[0x15] rec0=15 rec1=00 rec2=0c rec3=01c
[0x16] rec0=02 rec1=00 rec2=11 rec3=036
[0x17] rec0=12 rec1=00 rec2=19 rec3=018
[0x18] rec0=1d rec1=00 rec2=1b rec3=084
[0x19] rec0=1c rec1=00 rec2=15 rec3=04e
[0x1a] rec0=14 rec1=00 rec2=08 rec3=066
[0x1b] rec0=01 rec1=00 rec2=25 rec3=03e
[0x1c] rec0=16 rec1=00 rec2=21 rec3=02c
[0x1d] rec0=04 rec1=00 rec2=09 rec3=03a
[0x1e] rec0=19 rec1=00 rec2=0b rec3=028
[0x1f] rec0=1c rec1=00 rec2=02 rec3=000
[0x20] rec0=1b rec1=00 rec2=02 rec3=014
[0x21] rec0=1a rec1=00 rec2=13 rec3=000
[0x22] rec0=1b rec1=00 rec2=13 rec3=040
[0x23] rec0=1c rec1=00 rec2=0e rec3=014
[0x24] rec0=05 rec1=00 rec2=1d rec3=000
tail 0x2176b692c895942fabbb9 0x42a00088462063c03
Free Block Chain:
0x12: 0000 00 18 00 4d 80 01 3b 01 00 29 20 20 20 20 20 20 ┆ M ; ) ┆
0x18: 0000 00 0d 00 06 00 03 20 20 20 03 00 08 20 20 20 20 ┆ ┆
0xd: 0000 00 1d 00 3d 80 0f 6e 6b 20 20 20 20 3d 3e 20 42 ┆ = nk => B┆
0x1d: 0000 00 24 00 53 80 06 66 65 63 74 65 3b 06 00 05 62 ┆ $ S fecte; b┆
0x24: 0000 00 00 00 4b 80 14 20 20 20 20 20 20 20 3a 3d 20 ┆ K := ┆