|
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: 38912 (0x9800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Terminal, seg_05978f
└─⟦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 Coordonnees;
use Coordonnees;
with Terminaux;
use Terminaux;
package body Terminal is
task type Wait_Event is
entry Go (H : in Handle);
end Wait_Event;
type T_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 Objet is
record
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_Acc;
Stop : Boolean;
X_Request_Count : Natural;
Next, Prev : Handle;
end record;
Null_Objet : constant Objet := (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;
task 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;
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
Buffer_Task.Get (Terminal => Terminal,
C => Rc,
X => X,
Y => Y,
Blink => Blink,
Succes => Succes);
while Succes loop
Envoyer (Terminal => Terminal,
C => Rc,
X => X,
Y => Y,
Blink => Blink);
Buffer_Task.Get (Terminal => Terminal,
C => Rc,
X => X,
Y => Y,
Blink => Blink,
Succes => Succes);
end loop;
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);
State := Wait_Release;
exception
when others =>
null;
end;
end if;
when Key_Release =>
if State = Wait_Release then
State := Wait_Read;
Envoyer_Caractere (C => C, No => Terminal.No);
State := Wait_Press;
end if;
when others =>
null;
end case;
else
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;
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
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;
E, First_F, First_B, Last_B : Enreg_P := null;
Tc : Character;
function Get return Enreg_P is
El : Enreg_P;
begin
if First_F = null then
El := new Enreg_T;
else
El := First_F;
First_F := El.Next;
end if;
El.Prev := Last_B;
El.Next := null;
if Last_B /= null then
Last_B.Next := El;
end if;
Last_B := El;
if First_B = null then
First_B := El;
end if;
return El;
end Get;
procedure Put (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
First_B := El.Next;
El.Next.Prev := null;
end if;
else
if El.Prev /= null then
Last_B := El.Prev;
El.Prev.Next := null;
else
First_B := null;
Last_B := null;
end if;
end if;
El.Next := First_F;
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;
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 := 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 (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
Buffer_Task.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;
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;
end Terminal;
nblk1=25
nid=8
hdr6=38
[0x00] rec0=12 rec1=00 rec2=01 rec3=020
[0x01] rec0=18 rec1=00 rec2=25 rec3=016
[0x02] rec0=05 rec1=00 rec2=07 rec3=02c
[0x03] rec0=10 rec1=00 rec2=14 rec3=02e
[0x04] rec0=1a rec1=00 rec2=22 rec3=022
[0x05] rec0=19 rec1=00 rec2=1a rec3=05c
[0x06] rec0=1a rec1=00 rec2=23 rec3=02e
[0x07] rec0=16 rec1=00 rec2=20 rec3=00c
[0x08] rec0=13 rec1=00 rec2=04 rec3=030
[0x09] rec0=1c rec1=00 rec2=0f rec3=034
[0x0a] rec0=17 rec1=00 rec2=06 rec3=038
[0x0b] rec0=01 rec1=00 rec2=1e rec3=04e
[0x0c] rec0=17 rec1=00 rec2=10 rec3=01c
[0x0d] rec0=00 rec1=00 rec2=17 rec3=024
[0x0e] rec0=17 rec1=00 rec2=1f rec3=046
[0x0f] rec0=01 rec1=00 rec2=05 rec3=006
[0x10] rec0=15 rec1=00 rec2=0a rec3=05e
[0x11] rec0=00 rec1=00 rec2=0c rec3=020
[0x12] rec0=16 rec1=00 rec2=11 rec3=01e
[0x13] rec0=01 rec1=00 rec2=03 rec3=036
[0x14] rec0=12 rec1=00 rec2=19 rec3=018
[0x15] rec0=1e rec1=00 rec2=1b rec3=016
[0x16] rec0=1f rec1=00 rec2=15 rec3=032
[0x17] rec0=16 rec1=00 rec2=21 rec3=024
[0x18] rec0=00 rec1=00 rec2=0e rec3=006
[0x19] rec0=15 rec1=00 rec2=09 rec3=04c
[0x1a] rec0=1a rec1=00 rec2=0b rec3=068
[0x1b] rec0=13 rec1=00 rec2=02 rec3=000
[0x1c] rec0=13 rec1=00 rec2=0b rec3=04a
[0x1d] rec0=19 rec1=00 rec2=02 rec3=05c
[0x1e] rec0=1e rec1=00 rec2=0e rec3=000
[0x1f] rec0=13 rec1=00 rec2=0b rec3=04a
[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 0x2176809fa890894d891d6 0x42a00088462063c03
Free Block Chain:
0x8: 0000 00 16 03 fc 80 1d 70 74 20 50 75 74 20 28 54 65 ┆ pt Put (Te┆
0x16: 0000 00 12 00 24 80 08 6c 65 61 6e 29 20 64 6f 08 00 ┆ $ lean) do ┆
0x12: 0000 00 13 00 12 80 0f 20 20 20 20 20 20 20 20 20 20 ┆ ┆
0x13: 0000 00 1c 03 fc 80 37 20 20 20 20 20 20 20 20 20 20 ┆ 7 ┆
0x1c: 0000 00 18 00 04 80 01 3b 01 20 20 20 20 20 20 20 20 ┆ ; ┆
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 := ┆