|
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: 24576 (0x6000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Xlbp_Font, seg_004f5f
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Extension;
use Xlbt_Extension;
with Xlbt_Font;
use Xlbt_Font;
with Xlbt_Font2;
use Xlbt_Font2;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_String;
use Xlbt_String;
with Xlbp_Extension;
use Xlbp_Extension;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbip_Get_Reply;
use Xlbip_Get_Reply;
with Xlbip_Internal;
use Xlbip_Internal;
with Xlbip_Put_Request;
use Xlbip_Put_Request;
with Xlbmt_Network_Types;
use Xlbmt_Network_Types;
package body Xlbp_Font is
------------------------------------------------------------------------------
-- X Library Fonts
--
-- Xlbp_Font - Loading and using fonts.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1985 - 1989 by the Massachusetts Institute of Technology
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the names of MIT or Rational not be
-- used in advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- MIT and Rational disclaim all warranties with regard to this software,
-- including all implied warranties of merchantability and fitness, in no
-- event shall MIT or Rational be liable for any special, indirect or
-- consequential damages or any damages whatsoever resulting from loss of use,
-- data or profits, whether in an action of contract, negligence or other
-- tortious action, arising out of or in connection with the use or performance
-- of this software.
------------------------------------------------------------------------------
--\x0c
procedure Private_X_Query_Font (Display : X_Display;
Fid : X_Font;
Fst : out X_Font_Struct;
Status : out X_Status) is
-- Internal-only entry point
Fs : X_Font_Struct;
Reply : X_Reply_Contents;
Ext : X_Extension;
Succ : X_Status;
begin
----Send the request.
Put_X_Query_Font_Request
(Display, (Kind => Query_Font,
Length => X_Query_Font_Request'Size / 32,
Pad => 0,
Id => Fid));
----Get the reply header.
Get_Reply (Display => Display,
Code => Query_Font,
Reply => Reply,
Extra => 0,
Discard => False,
Status => Succ);
if Succ = Failed then
Fst := None_X_Font_Struct;
Status := Failed;
return;
end if;
----Get the font struct for the reply.
begin
Fs := new X_Font_Struct_Rec'
((Ext_Data => null,
Font_Id => Fid,
Direction => Reply.Query_Font.Draw_Direction,
Default_Char =>
(Char1 => U_Char (Reply.Query_Font.
Default_Char / 256),
Char2 => U_Char (Reply.Query_Font.
Default_Char rem 256)),
Min_Byte1 => Reply.Query_Font.Min_Byte1,
Max_Byte1 => Reply.Query_Font.Max_Byte1,
Min_Char_Or_Byte2 =>
Reply.Query_Font.Min_Char_Or_Byte2,
Max_Char_Or_Byte2 =>
Reply.Query_Font.Max_Char_Or_Byte2,
All_Chars_Exist =>
To_Boolean (Reply.Query_Font.All_Chars_Exist),
Ascent => Reply.Query_Font.Font_Ascent,
Descent => Reply.Query_Font.Font_Descent,
Min_Bounds => Reply.Query_Font.Min_Bounds,
Max_Bounds => Reply.Query_Font.Max_Bounds,
Properties => null,
Per_Char => null));
exception
when others =>
Eat_Raw_Data
(Display,
S_Natural (Reply.Query_Font.N_Font_Props) *
X_Font_Prop'Size / 8 +
S_Natural (Reply.Query_Font.Max_Byte1 -
Reply.Query_Font.Min_Byte1 + 1) *
S_Natural (Reply.Query_Font.Max_Char_Or_Byte2 -
Reply.Query_Font.Min_Char_Or_Byte2 + 1) *
X_Char_Struct'Size / 8);
raise;
end;
----Get the properties. If no properties defined for the font, then it is a bad
-- font, but shouldn't try to read nothing.
if Reply.Query_Font.N_Font_Props > 0 then
begin
Fs.Properties :=
new X_Font_Prop_Array
(1 .. S_Natural (Reply.Query_Font.N_Font_Props));
exception
when others =>
Eat_Raw_Data
(Display,
S_Natural (Reply.Query_Font.N_Font_Props) *
X_Font_Prop'Size / 8 +
S_Natural (Reply.Query_Font.Max_Byte1 -
Reply.Query_Font.Min_Byte1 + 1) *
S_Natural (Reply.Query_Font.Max_Char_Or_Byte2 -
Reply.Query_Font.Min_Char_Or_Byte2 + 1) *
X_Char_Struct'Size / 8);
raise;
end;
Get_X_Font_Prop_Array (Display, Fs.Properties.all);
end if;
----Get the name. If no characters in font name, then it is a bad font, but
-- shouldn't try to read nothing.
if Reply.Query_Font.N_Char_Infos > 0 then
begin
--/ if not TeleGen2_2d_Bug then
Fs.Per_Char :=
new X_Char_Struct_Array_2d
(Reply.Query_Font.Min_Byte1 ..
Reply.Query_Font.Max_Byte1,
U_Char (Reply.Query_Font.Min_Char_Or_Byte2) ..
U_Char (Reply.Query_Font.Max_Char_Or_Byte2));
--/ else
--// Fs.Per_Char :=
--// new X_Char_Struct_Array_2d
--// (Telegen2_2d_Bug (Reply.Query_Font.Min_Byte1) ..
--// Telegen2_2d_Bug (Reply.Query_Font.Max_Byte1),
--// U_Char (Reply.Query_Font.Min_Char_Or_Byte2) ..
--// U_Char (Reply.Query_Font.Max_Char_Or_Byte2));
--/ end if;
exception
when others =>
Eat_Raw_Data
(Display, S_Natural
(Reply.Query_Font.Max_Char_Or_Byte2 -
Reply.Query_Font.Min_Char_Or_Byte2 + 1) *
S_Natural (Reply.Query_Font.Max_Byte1 -
Reply.Query_Font.Min_Byte1 + 1));
raise;
end;
Get_X_Char_Struct_Array_2d (Display, Fs.Per_Char.all);
end if;
----Notify extensions about font.
Ext := Display.Ext_Procs;
while Ext /= null loop
if Ext.Create_Font /= None_X_Procedure_Variable then
Proc_Var_X_Display_Font_Extension.Call
(Proc_Var_X_Display_Font_Extension.To_Pv (Ext.Create_Font),
Display, Fs, Ext.Codes);
end if;
Ext := Ext.Next;
end loop;
Fst := Fs;
Status := Successful;
end Private_X_Query_Font;
--\x0c
function X_Load_Query_Font (Display : X_Display;
Name : X_String) return X_Font_Struct is
Font_Result : X_Font_Struct;
N_Bytes : U_Short;
Fid : X_Font;
Seq_Adj : S_Long := 1;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
N_Bytes := Name'Length;
Fid := (Id => Xlbp_Extension.X_Alloc_Id (Display));
Put_X_Open_Font_Request
(Display,
(Kind => Open_Font,
Length => X_Open_Font_Request'Size / 32 + (N_Bytes + 3) / 4,
Pad => 0,
Pad1 => 0,
Pad2 => 0,
Font => Fid,
N_Bytes => N_Bytes), S_Natural (N_Bytes));
Put_X_String (Display, Name);
----Get the result.
Display.Request := Display.Request - Seq_Adj;
Private_X_Query_Font (Display, Fid, Font_Result, Succ);
Display.Request := Display.Request + Seq_Adj;
if Succ = Failed then
----If private_X_Query_Font returned NULL, then the Open_Font
-- request got a Bad_Name error. This means that the following
-- Query_Font request is guaranteed to get a Bad_Font error,
-- since the id passed to Query_Font wasn't really a valid font
-- id. To read and discard this second error, we call
-- Get_Reply again.
declare
Reply : X_Reply_Contents;
Void : X_Status;
begin
Get_Reply (Display, Query_Font, Reply, 0, True, Void);
end;
end if;
----Catch.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Return.
Unlock_Display (Display);
Sync_Handle (Display);
return Font_Result;
end X_Load_Query_Font;
--\x0c
procedure X_Free_Font (Display : X_Display;
Font : in out X_Font_Struct) is
Ext : X_Extension;
begin
----Watch out for nulls.
if Font = None_X_Font_Struct then
return;
end if;
----Lock.
Lock_Display (Display);
begin
----See if anybody cares.
while Ext /= null loop -- call out to any extensions interested
if Ext.Free_Font /= None_X_Procedure_Variable then
Proc_Var_X_Display_Font_Extension.Call
(Proc_Var_X_Display_Font_Extension.To_Pv (Ext.Free_Font),
Display, Font, Ext.Codes);
end if;
Ext := Ext.Next;
end loop;
----Send the request.
Put_X_Close_Font_Request
(Display, (Kind => Close_Font,
Length => X_Close_Font_Request'Size / 32,
Pad => 0,
Id => Font.Font_Id));
Free_X_Ext_Data (Font.Ext_Data);
if Font.Per_Char /= null then
Free_X_Char_Struct_List_2d (Font.Per_Char);
end if;
if Font.Properties /= null then
Free_X_Font_Prop_List (Font.Properties);
end if;
Free_X_Font_Struct (Font);
----Catch.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Free_Font;
--\x0c
function X_Query_Font (Display : X_Display;
Font : X_Font) return X_Font_Struct is
Succ : X_Status;
Fs : X_Font_Struct;
begin
Lock_Display (Display);
begin
Private_X_Query_Font (Display, Font, Fs, Succ);
exception
when others =>
Unlock_Display (Display);
raise;
end;
Unlock_Display (Display);
Sync_Handle (Display);
if Succ = Failed then
return None_X_Font_Struct;
else
return Fs;
end if;
end X_Query_Font;
--\x0c
function X_Load_Font (Display : X_Display;
Name : X_String) return X_Font is
N_Bytes : S_Natural;
Fid : X_Font;
begin
----Lock the display.
Lock_Display (Display);
begin
----Create a new font id and send our request.
N_Bytes := Name'Length;
Fid := (Id => Xlbp_Extension.X_Alloc_Id (Display));
Put_X_Open_Font_Request
(Display,
(Kind => Open_Font,
Length =>
X_Open_Font_Request'Size / 32 + U_Short (N_Bytes + 3) / 4,
Pad => 0,
Pad1 => 0,
Pad2 => 0,
N_Bytes => U_Short (N_Bytes),
Font => Fid),
N_Bytes);
Put_X_String (Display, Name);
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync up; return new font id.
Unlock_Display (Display);
Sync_Handle (Display);
return Fid;
end X_Load_Font;
--\x0c
procedure X_Unload_Font (Display : X_Display;
Font : X_Font) is
begin
----Lock display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Close_Font_Request
(Display, (Kind => Close_Font,
Length => X_Close_Font_Request'Size / 32,
Pad => 0,
Id => Font));
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; and sync.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Unload_Font;
--\x0c
procedure X_Get_Font_Property (Font : X_Font_Struct;
Name : X_Atom;
Value : out S_Long;
Status : out X_Status) is
-- X_XX this is a simple linear search for now. If the
--protocol is changed to sort the property list, this should
--become a binary search.
begin
for I in Font.Properties'Range loop
if Font.Properties (I).Name = Name then
Value := Font.Properties (I).Data32;
Status := Successful;
return;
end if;
end loop;
Value := 0;
Status := Failed;
return;
end X_Get_Font_Property;
end Xlbp_Font;
nblk1=17
nid=0
hdr6=2e
[0x00] rec0=2c rec1=00 rec2=01 rec3=00c
[0x01] rec0=11 rec1=00 rec2=02 rec3=02a
[0x02] rec0=1b rec1=00 rec2=03 rec3=02c
[0x03] rec0=00 rec1=00 rec2=17 rec3=00c
[0x04] rec0=17 rec1=00 rec2=04 rec3=082
[0x05] rec0=00 rec1=00 rec2=16 rec3=006
[0x06] rec0=10 rec1=00 rec2=05 rec3=00a
[0x07] rec0=16 rec1=00 rec2=06 rec3=040
[0x08] rec0=17 rec1=00 rec2=07 rec3=01a
[0x09] rec0=11 rec1=00 rec2=08 rec3=0a0
[0x0a] rec0=1b rec1=00 rec2=09 rec3=030
[0x0b] rec0=00 rec1=00 rec2=15 rec3=006
[0x0c] rec0=1f rec1=00 rec2=0a rec3=020
[0x0d] rec0=00 rec1=00 rec2=14 rec3=036
[0x0e] rec0=1b rec1=00 rec2=0b rec3=040
[0x0f] rec0=24 rec1=00 rec2=0c rec3=050
[0x10] rec0=21 rec1=00 rec2=0d rec3=006
[0x11] rec0=00 rec1=00 rec2=13 rec3=004
[0x12] rec0=25 rec1=00 rec2=0e rec3=020
[0x13] rec0=00 rec1=00 rec2=12 rec3=010
[0x14] rec0=2a rec1=00 rec2=0f rec3=008
[0x15] rec0=1f rec1=00 rec2=10 rec3=028
[0x16] rec0=0e rec1=00 rec2=11 rec3=000
tail 0x217006bf0819782354b0f 0x42a00088462063203