|
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 - metrics - downloadIndex: B T
Length: 20496 (0x5010)
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_Font;
use Xlbt_Font;
with Xlbt_Font2;
use Xlbt_Font2;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_String;
use Xlbt_String;
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_Names is
------------------------------------------------------------------------------
-- X Library Font Names
--
-- Xlbp_Font_Names - What fonts are there and where do they live?
------------------------------------------------------------------------------
-- 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
function X_Get_Font_Path (Display : X_Display)
return X_String_Pointer_List is
Rep : X_Reply_Contents;
Length : S_Natural;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Get_Font_Path_Request
(Display, (Kind => Get_Font_Path,
Length => X_Get_Font_Path_Request'Size / 32,
Pad => 0));
----Get the reply.
Get_Reply (Display => Display,
Code => Get_Font_Path,
Reply => Rep,
Extra => 0,
Discard => False,
Status => Succ);
----Watch for failure.
if Succ = Failed then
Unlock_Display (Display);
Sync_Handle (Display);
return None_X_String_Pointer_List;
end if;
----Return the results.
if Rep.Get_Font_Path.N_Paths /= 0 then
declare
Amount : S_Natural;
Flist : X_String_Pointer_List;
Ch : X_String (1 ..
S_Natural (Rep.Get_Font_Path.Length) * 4);
begin
Get_X_String (Display, Ch);
Flist := new X_String_Pointer_Array
(1 .. S_Natural
(Rep.Get_Font_Path.N_Paths));
Length := 1;
for I in Flist'Range loop
for J in Length .. Ch'Last loop
if Ch (J) = Nul then
Amount := J - Length;
----Ada may not be able to take the full
-- amount. Chop the string if necessary.
--/ if not Positive_Is_Large then
--// if Amount > S_Natural (Positive'Last) then
--// Amount := S_Natural (Positive'Last);
--// end if;
--/ end if;
Flist (I) := new X_String (1 .. Amount);
Flist (I).all :=
Ch (Length .. Length + Amount - 1);
Length := J + 1;
end if;
end loop;
end loop;
Unlock_Display (Display);
Sync_Handle (Display);
return Flist;
exception
when others =>
Free_X_String_Pointer_List (Flist);
raise;
end;
else
Unlock_Display (Display);
Sync_Handle (Display);
return None_X_String_Pointer_List;
end if;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_Get_Font_Path;
--\f
procedure X_Set_Font_Path (Display : X_Display;
Directories : X_String_Pointer_Array) is
N : S_Natural := 0;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
for I in Directories'Range loop
N := N + Directories (I)'Length + 1;
end loop;
Put_X_Set_Font_Path_Request
(Display,
(Kind => Set_Font_Path,
Length =>
X_Set_Font_Path_Request'Size / 32 + U_Short ((N + 3) / 4),
Pad => 0,
Pad1 => 0,
Pad2 => 0,
N_Fonts => Directories'Length),
N);
----Send the directory strings.
declare
P : X_String (1 .. N);
Pi : S_Natural := P'First;
begin
--
-- pack into counted strings.
--
for I in Directories'Range loop
declare
Sp : X_String_Pointer := Directories (I);
begin
for J in Sp'Range loop
P (Pi) := Sp (J);
Pi := Pi + 1;
end loop;
end;
P (Pi) := Nul;
Pi := Pi + 1;
end loop;
Put_X_String (Display, P);
end;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Font_Path;
--\f
procedure X_Free_Font_Info (Info : in out X_Fonts_With_Info) is
begin
for I in Info.Info'Range loop
declare
Fs : X_Font_Struct := Info.Info (I);
begin
Free_X_Char_Struct_List_2d (Fs.Per_Char);
Free_X_Font_Prop_List (Fs.Properties);
Free_X_Font_Struct (Fs);
Info.Info (I) := None_X_Font_Struct;
end;
Free_X_String_Pointer (Info.Name (I));
end loop;
end X_Free_Font_Info;
--\f
function X_List_Fonts_With_Info
(Display : X_Display;
Pattern : X_String; -- null-terminated
Maximum_Names : U_Short) return X_Fonts_With_Info is
N_Bytes : U_Short;
Fs : S_Natural := 0;
Fsi : X_Font_Struct;
Info : X_Fonts_With_Info;
Reply : X_Reply_Contents;
Succ : X_Status;
procedure Free_It_All is
begin
for J in 1 .. Fs loop
Free_X_String_Pointer (Info.Name (Fs));
Fsi := Info.Info (Fs);
if Fsi.Properties /= null then
Free_X_Font_Prop_List (Fsi.Properties);
end if;
end loop;
end Free_It_All;
begin
----Lock the display;
Lock_Display (Display);
begin
Info.Info := new X_Font_Struct_Array
(1 .. S_Natural (Maximum_Names));
Info.Name := new X_String_Pointer_Array
(1 .. S_Natural (Maximum_Names));
----Send the request.
N_Bytes := Pattern'Length;
Put_X_List_Fonts_With_Info_Request
(Display,
(Kind => List_Fonts_With_Info,
Length => X_List_Fonts_With_Info_Request'Size / 32 +
(N_Bytes + 3) / 4,
Pad => 0,
Max_Names => Maximum_Names,
N_Bytes => N_Bytes), S_Natural (N_Bytes));
----Send the pattern.
Put_X_String (Display, Pattern);
----Read replies until we get one with 0 length.
for I in U_Short'First .. U_Short'Last loop
Get_Reply (Display => Display,
Code => List_Fonts_With_Info,
Reply => Reply,
Extra => 0,
Discard => False,
Status => Succ);
----Any failure means abort the whole thing.
if Succ = Failed then
Free_It_All;
Unlock_Display (Display);
Sync_Handle (Display);
return (Info => None_X_Font_Struct_List,
Name => None_X_String_Pointer_List);
end if;
----Zero length reply; end-of-list.
if Reply.List_Fonts_With_Info.Name_Length = 0 then
exit;
end if;
----Convert this reply into a font struct. (no per_char info)
Fs := S_Natural (I);
begin
Fsi :=
new X_Font_Struct_Rec'
((Ext_Data => null,
Font_Id => None_X_Font,
Direction =>
Reply.List_Fonts_With_Info.Draw_Direction,
Default_Char =>
(Char1 => U_Char (Reply.List_Fonts_With_Info.
Default_Char / 256),
Char2 => U_Char (Reply.List_Fonts_With_Info.
Default_Char rem 256)),
Min_Char_Or_Byte2 =>
Reply.List_Fonts_With_Info.Min_Char_Or_Byte2,
Max_Char_Or_Byte2 =>
Reply.List_Fonts_With_Info.Max_Char_Or_Byte2,
Min_Byte1 =>
Reply.List_Fonts_With_Info.Min_Byte1,
Max_Byte1 =>
Reply.List_Fonts_With_Info.Max_Byte1,
All_Chars_Exist =>
To_Boolean (Reply.List_Fonts_With_Info.
All_Chars_Exist),
Ascent =>
Reply.List_Fonts_With_Info.Font_Ascent,
Descent =>
Reply.List_Fonts_With_Info.Font_Descent,
Min_Bounds =>
Reply.List_Fonts_With_Info.Min_Bounds,
Max_Bounds =>
Reply.List_Fonts_With_Info.Max_Bounds,
Per_Char => null,
Properties => null));
exception
when others =>
Eat_Raw_Data
(Display,
S_Natural
(Reply.List_Fonts_With_Info.N_Font_Props) *
X_Font_Prop'Size / 8 +
S_Natural (Reply.List_Fonts_With_Info.Name_Length));
Free_It_All;
raise;
end;
Info.Info (Fs) := Fsi;
----Read the properties.
if Reply.List_Fonts_With_Info.N_Font_Props > 0 then
begin
Fsi.Properties :=
new X_Font_Prop_Array
(1 .. S_Natural (Reply.List_Fonts_With_Info.
N_Font_Props));
exception
when others =>
Eat_Raw_Data (Display,
S_Natural (Reply.List_Fonts_With_Info.
N_Font_Props) *
X_Font_Prop'Size / 8 +
S_Natural (Reply.List_Fonts_With_Info.
Name_Length));
Free_It_All;
raise;
end;
Get_X_Font_Prop_Array (Display, Fsi.Properties.all);
end if;
----Read the name.
declare
Buff : X_String (1 .. S_Natural (Reply.List_Fonts_With_Info.
Name_Length));
begin
Get_X_String (Display, Buff);
Info.Name (Fs) := new X_String'(Buff);
exception
when others =>
Free_It_All;
raise;
end;
end loop;
----Return our lists.
declare
Inf : X_Fonts_With_Info;
begin
Inf.Info := new X_Font_Struct_Array'(Info.Info (1 .. Fs));
Inf.Name := new X_String_Pointer_Array'(Info.Name (1 .. Fs));
Unlock_Display (Display);
Sync_Handle (Display);
return Inf;
exception
when others =>
Inf.Info.all := (Inf.Info'Range => None_X_Font_Struct);
Inf.Name.all := (Inf.Name'Range => None_X_String_Pointer);
Free_X_Font_Struct_List (Inf.Info);
Free_X_String_Pointer_List (Inf.Name);
raise;
end;
----Catch exceptions.
exception
when Storage_Error =>
----Free up heap storage.
Free_It_All;
----Read the rest of the replies. We know that we are at a reply-boundary
-- because all of the code up above does it's best to get us there.
for I in U_Short'First .. U_Short'Last loop
Get_Reply (Display => Display,
Code => List_Fonts_With_Info,
Reply => Reply,
Extra => 0,
Discard => False,
Status => Succ);
----Any failure means abort the whole thing. Zero length reply; end-of-list.
if Succ = Failed or else
Reply.List_Fonts_With_Info.Name_Length = 0 then
exit;
end if;
----Read the properties and the name.
Eat_Raw_Data
(Display,
S_Natural (Reply.List_Fonts_With_Info.N_Font_Props) *
X_Font_Prop'Size / 8 +
S_Natural (Reply.List_Fonts_With_Info.Name_Length));
end loop;
Unlock_Display (Display);
raise;
----Other types of exceptions are unexpected and may constitute bugs. In any
-- case we don't know how to recover from them.
when others =>
Free_It_All;
Unlock_Display (Display);
raise;
end;
end X_List_Fonts_With_Info;
--\f
function X_List_Fonts
(Display : X_Display;
Pattern : X_String;
Maximum_Names : U_Short) return X_String_Pointer_List is
N_Bytes : U_Short;
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
N_Bytes := Pattern'Length;
Put_X_List_Fonts_Request
(Display,
(Kind => List_Fonts,
Length => X_List_Fonts_Request'Size / 32
+ (N_Bytes + 3) / 4,
Pad => 0,
Max_Names => Maximum_Names,
N_Bytes => N_Bytes), S_Natural (N_Bytes));
Put_X_String (Display, Pattern);
----Get the reply.
Get_Reply (Display => Display,
Code => List_Fonts,
Reply => Rep,
Extra => 0,
Discard => False,
Status => Succ);
if Succ = Failed then
Unlock_Display (Display);
Sync_Handle (Display);
return None_X_String_Pointer_List;
end if;
----Get the info we requested.
if Rep.List_Fonts.N_Fonts /= 0 then
declare
Amount : S_Natural;
Flist : X_String_Pointer_List;
Ch : X_String (1 .. S_Natural (Rep.List_Fonts.Length) * 4);
Chs : S_Natural;
Chf : S_Natural;
begin
Get_X_String (Display, Ch);
Flist := new X_String_Pointer_Array
(1 .. S_Natural (Rep.List_Fonts.N_Fonts));
Chs := 1;
Chf := 1;
for I in Flist'Range loop
while Chf <= Ch'Last and then Ch (Chf) /= Nul loop
Chf := Chf + 1;
end loop;
Amount := Chf - Chs;
--/ if not Positive_Is_Large then
--// if Amount > S_Natural (Positive'Last) then
--// Amount := S_Natural (Positive'Last);
--// end if;
--/ end if;
Flist (I) := new X_String (1 .. Amount);
Flist (I).all := Ch (Chs .. Chf - 1);
Chs := Chf + 1;
Chf := Chs;
end loop;
Unlock_Display (Display);
Sync_Handle (Display);
return Flist;
exception
when others =>
Free_X_String_Pointer_List (Flist);
raise;
end;
else
Unlock_Display (Display);
Sync_Handle (Display);
return None_X_String_Pointer_List;
end if;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_List_Fonts;
--\f
end Xlbp_Font_Names;