|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 15770 (0x3d9a)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦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.
------------------------------------------------------------------------------
--\f
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;
--\f
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;
--\f
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;
--\f
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;
--\f
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;
--\f
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;
--\f
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;