mnerv/freetype
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

FreeType 1.31.1

Browse Source
This commit is contained in:
mnerv
2023-08-27 18:03:45 +02:00
commit 5edbb7a80a
454 changed files with 173977 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1931
pascal/lib/freetype.pas Normal file
View File

File diff suppressed because it is too large Load Diff

433
pascal/lib/ttcache.pas Normal file
View File

@@ -0,0 +1,433 @@
(*******************************************************************
*
* ttcache.pas 1.0
*
* Generic object cache
*
* Copyright 1996, 1997 by
* David Turner, Robert Wilhelm, and Werner Lemberg.
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
*
* This component defines and implement object caches.
*
* An object class is a structure layout that encapsulate one
* given type of data used by the FreeType engine. Each object
* class is completely described by :
*
* - a 'root' or 'leading' structure containing the first
* important fields of the class. The root structure is
* always of fixed size.
*
* It is implemented as a simple C structure, and may
* contain several pointers to sub-tables that can be
* sized and allocated dynamically.
*
* examples : TFace, TInstance, TGlyph & TExecution_Context
* ( defined in 'ttobjs.h' )
*
* - we make a difference between 'child' pointers and 'peer'
* pointers. A 'child' pointer points to a sub-table that is
* owned by the object, while a 'peer' pointer points to any
* other kind of data the object isn't responsible for.
*
* An object class is thus usually a 'tree' of 'child' tables.
*
* - each object class needs a constructor and a destructor.
*
* A constructor is a function which receives the address of
* freshly allocated and zeroed object root structure and
* 'builds' all the valid child data that must be associated
* to the object before it becomes 'valid'.
*
* A destructor does the inverse job : given the address of
* a valid object, it must discards all its child data and
* zero its main fields (essentially the pointers and array
* sizes found in the root fields).
*
*
*
*
*
*
*
*
*
*
*
*
******************************************************************)
unit TTCache;
interface
uses TTError, TTTypes;
type
(* Simple list node record. A List element is said to be 'unlinked' *)
(* when it doesn't belong to any list *)
(* *)
PList_Element = ^TList_Element;
TList_Element = record
next : PList_Element; (* Pointer to next element of list *)
data : Pointer; (* Pointer to the listed object *)
end;
(* Simple singly-linked list record *)
(* LIFO - style, no tail field *)
TSingle_List = PList_Element;
TConstructor = function( _object : Pointer;
_parent : Pointer ) : TError;
TDestructor = function( _object : Pointer ) : TError;
PCache_Class = ^TCache_Class;
TCache_Class = record
Object_Size : Int;
Idle_Limit : Int;
Init : TConstructor;
Done : TDestructor;
end;
(* A Cache class record holds the data necessary to define *)
(* a cache kind. *)
PCache = ^TCache;
TCache = record
clazz : PCache_Class; (* 'class' reserved in VP & Delphi *)
active : TSingle_List;
idle : TSingle_List;
idle_count : Int;
end;
(* An object cache holds two lists tracking the active and *)
(* idle objects that are currently created and used by the *)
(* engine. It can also be 'protected' by a mutex *)
function Cache_Create( var clazz : TCache_Class;
var cache : TCache ) : TError;
(* Initialize a new cache named 'cache', of class 'clazz', and *)
(* protected by the 'lock' mutex. Note that the mutex is ignored *)
(* as the pascal version isn't thread-safe *)
function Cache_Destroy( var cache : TCache ) : TError;
(* Destroys a cache and all its listed objects *)
function Cache_New( var cache : TCache;
var new_object : Pointer;
parent_data : Pointer ) : TError;
(* Extracts a new object from the cache. *)
function Cache_Done( var cache : TCache; obj : Pointer ) : TError;
(* returns an object to the cache, or discards it depending *)
(* on the cache class' "idle_limit" field *)
(********************************************************)
(* *)
(* Two functions used to manage list elements *)
(* *)
(* Note that they're thread-safe in multi-threaded *)
(* builds. *)
(* *)
function Element_New : PList_Element;
(* Returns a new list element, either fresh or recycled *)
(* Note : the returned element is unlinked *)
procedure Element_Done( element : PList_Element );
(* Recycles or discards an element. *)
(* Note : The element must be unlinked !! *)
function TTCache_Init : TError;
function TTCache_Done : TError;
implementation
uses TTMemory;
const
Null_Single_List = nil;
var
Free_Elements : PList_Element;
(*******************************************************************
*
* Function : Element_New
*
* Description : Gets a new ( either fresh or recycled ) list
* element. The element is unlisted.
*
* Notes : returns nil if out of memory
*
*****************************************************************)
function Element_New : PList_Element;
var
element : PList_Element;
begin
(* LOCK *)
if Free_Elements <> nil then
begin
element := Free_Elements;
Free_Elements := element^.next;
end
else
begin
Alloc( element, sizeof(TList_Element) );
(* by convention, an allocated block is always zeroed *)
(* the fields of element need not be set to NULL then *)
end;
(* UNLOCK *)
Element_New := element;
end;
(*******************************************************************
*
* Function : Element_Done
*
* Description : recycles an unlisted list element
*
* Notes : Doesn't check that the element is unlisted
*
*****************************************************************)
procedure Element_Done( element : PList_Element );
begin
(* LOCK *)
element^.next := Free_Elements;
Free_Elements := element;
(* UNLOCK *)
end;
(*******************************************************************
*
* Function : Cache_Create
*
* Description : Create a new cache object
*
*****************************************************************)
function Cache_Create( var clazz : TCache_Class;
var cache : TCache ) : TError;
begin
cache.clazz := @clazz;
cache.idle_count := 0;
cache.active := Null_Single_List;
cache.idle := Null_Single_List;
Cache_Create := Success;
end;
(*******************************************************************
*
* Function : Cache_Destroy
*
* Description : Destroy a given cache object
*
*****************************************************************)
function Cache_Destroy( var cache : TCache ) : TError;
var
destroy : TDestructor;
current : PList_Element;
next : PList_Element;
begin
(* now destroy all active and idle listed objects *)
destroy := cache.clazz^.done;
(* active list *)
current := cache.active;
while current <> nil do
begin
next := current^.next;
destroy( current^.data );
Free( current^.data );
Element_Done( current );
current := next;
end;
cache.active := Null_SIngle_List;
(* idle list *)
current := cache.idle;
while current <> nil do
begin
next := current^.next;
destroy( current^.data );
Free( current^.data );
Element_Done( current );
current := next;
end;
cache.idle := Null_Single_List;
cache.clazz := nil;
cache.idle_count := 0;
Cache_Destroy := Success;
end;
(*******************************************************************
*
* Function : Cache_New
*
* Description : Extracts one 'new' object from a cache
*
* Notes : The 'parent_data' pointer is passed to the object's
* initialiser when the new object is created from
* scratch. Recycled objects do not use this pointer
*
*****************************************************************)
function Cache_New( var cache : TCache;
var new_object : Pointer;
parent_data : Pointer ) : TError;
var
error : TError;
current : PList_Element;
obj : Pointer;
label
Fail;
begin
(* LOCK *)
current := cache.idle;
if current <> nil then
begin
cache.idle := current^.next;
dec( cache.idle_count )
end;
(* UNLOCK *)
if current = nil then
begin
(* if no object was found in the cache, create a new one *)
if Alloc( obj, cache.clazz^.object_size ) then exit;
current := Element_New;
if current = nil then goto Fail;
current^.data := obj;
error := cache.clazz^.init( obj, parent_data );
if error then goto Fail;
end;
(* LOCK *)
current^.next := cache.active;
cache.active := current;
(* UNLOCK *)
new_object := current^.data;
Cache_New := Success;
exit;
Fail:
Free( obj );
Cache_New := Failure;
end;
(*******************************************************************
*
* Function : Cache_Done
*
* Description : Discards an object intro a cache
*
*****************************************************************)
function Cache_Done( var cache : TCache; obj : Pointer ) : TError;
var
error : TError;
element : PList_Element;
parent : ^PList_Element;
label
Suite;
begin
Cache_Done := failure;
(* find element in list *)
(* LOCK *)
parent := @cache.active;
element := parent^;
while element <> nil do
begin
if element^.data = obj then
begin
parent^ := element^.next;
(* UNLOCK *)
goto Suite;
end;
parent := @element^.next;
element := parent^;
end;
(* UNLOCK *)
(* Element wasn't found !! *)
{$IFDEF DEBUG}
{$ENDIF}
exit;
Suite:
if ( cache.idle_count >= cache.clazz^.idle_limit ) then
begin
(* destroy the object when the cache is full *)
cache.clazz^.done( element^.data );
Free( element^.data );
Element_Done( element );
end
else
begin
(* simply add the object to the idle list *)
(* LOCK *)
element^.next := cache.idle;
cache.idle := element;
inc( cache.idle_count );
(* UNLOCK *)
end;
Cache_Done := Success;
end;
function TTCache_Init : TError;
begin
Free_Elements := nil;
TTCache_Init := Success;
end;
function TTCache_Done : TError;
var
current, next : PList_ELement;
begin
current := free_elements;
while current <> nil do
begin
next := current^.next;
Free( current );
current := next;
end;
TTCache_Done := success;
end;
end.

289
pascal/lib/ttcalc.pas Normal file
View File

@@ -0,0 +1,289 @@
(*******************************************************************
*
* TTCalc.Pas 1.2
*
* Arithmetic and Vectorial Computations (specification)
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
* NOTES : All vector operations were moved to the interpreter
*
******************************************************************)
unit TTCalc;
interface
{$I TTCONFIG.INC}
type
(* IntN types : *)
(* *)
(* These types are used as a way to garantee the size of some *)
(* specific integers. *)
(* *)
(* Of course, they are equivalent to Short, UShort, Long, etc .. *)
(* but parts of this unit could be used by different programs. *)
(* *)
(* Define the 16-bit type *)
{$IFDEF BORLANDPASCAL}
Int16 = Integer;
Word16 = Word; (* 16-bits unsigned *)
{$ELSE}
{$IFDEF DELPHI16}
Int16 = Integer;
Word16 = Word; (* 16-bits unsigned *)
{$ELSE}
{$IFDEF DELPHI32}
Int16 = SmallInt;
Word16 = Word; (* 16-bits unsigned *)
{$ELSE}
Int16 = SmallInt;
Word16 = SmallWord; (* 16-bits unsigned *)
{$ENDIF}
{$ENDIF}
{$ENDIF}
Int32 = LongInt; (* 32 bits integer *)
Word32 = LongInt; (* 32 bits 'unsigned'. Note that there's *)
(* no unsigned long in Pascal.. *)
(* As cardinals are only 31 bits !! *)
Int64 = record (* 64 "" *)
Lo,
Hi : LongInt;
end;
function MulDiv( A, B, C : Int32 ): Int32;
function MulDiv_Round( A, B, C : Int32 ): Int32;
procedure Add64( var X, Y, Z : Int64 );
procedure Sub64( var X, Y, Z : Int64 );
procedure MulTo64( X, Y : Int32; var Z : Int64 );
function Div64by32( var X : Int64; Y : Int32 ) : Int32;
function Order64( var Z : Int64 ) : integer;
function Order32( Z : Int32 ) : integer;
function Sqrt32( L : Int32 ): LongInt;
function Sqrt64( L : Int64 ): LongInt;
{$IFDEF TEST}
procedure Neg64( var x : Int64 );
procedure DivMod64by32( var X : Int64; Y : Int32; var Q, R : Int32 );
{$ENDIF}
implementation
(* add support for Virtual Pascal inline assembly *)
{$IFDEF VIRTUALPASCAL}
{$I TTCALC2.INC}
{$ENDIF}
(* add support for Delphi 2 and 3 inline assembly *)
{$IFDEF DELPHI32}
{$I TTCALC3.INC}
{$ENDIF}
(* add support for Borland Pascal and Turbo Pascal inline assembly *)
{$IFDEF BORLANDPASCAL}
{$I TTCALC1.INC}
{$ENDIF}
(* Delphi 16 uses the same inline assembly than Borland Pascal *)
{$IFDEF DELPHI16}
{$I TTCALC1.INC}
{$ENDIF}
(* add support for Free Pascal inline assembly *)
{$IFDEF FPK}
{$I TTCALC4.INC}
{$ENDIF}
(*****************************************************************)
(* *)
(* MulDiv : computes A*B/C with an intermediate 64 bits *)
(* precision. *)
(* *)
(*****************************************************************)
function MulDiv( a, b, c : Int32 ) : Int32;
var
s : Int32;
temp : Int64;
begin
s := a; a := abs(a);
s := s xor b; b := abs(b);
s := s xor c; c := abs(c);
MulTo64( a, b, temp );
c := Div64by32( temp, c );
if s < 0 then c := -c;
MulDiv := c;
end;
(*****************************************************************)
(* *)
(* MulDiv : computes A*B/C with an intermediate 64 bits *)
(* _Round precision and rounding. *)
(* *)
(*****************************************************************)
function MulDiv_Round( a, b, c : Int32 ) : Int32;
var
s : Int32;
temp, temp2 : Int64;
begin
s := a; a := abs(a);
s := s xor b; b := abs(b);
s := s xor c; c := abs(c);
MulTo64( a, b, temp );
temp2.hi := 0;
temp2.lo := c div 2;
Add64( temp, temp2, temp );
c := Div64by32( temp, c );
if s < 0 then c := -c;
MulDiv_Round := c;
end;
(**********************************************************)
(* Negation *)
procedure Neg64( var x : Int64 );
begin
(* Remember that -(0x80000000) == 0x80000000 with 2-complement! *)
(* We take care of that here. *)
x.hi := x.hi xor $FFFFFFFF;
x.lo := x.lo xor $FFFFFFFF;
inc( x.lo );
if x.lo = 0 then
begin
inc( x.hi );
if x.hi = $80000000 then (* check -MaxInt32-1 *)
begin
dec( x.lo ); (* we return $7FFFFFFF *)
dec( x.hi );
end;
end;
end;
(**********************************************************)
(* MSB index ( return -1 for 0 ) *)
function Order64( var Z : Int64 ) : integer;
begin
if Z.Hi <> 0 then Order64 := 32 + Order32( Z.Hi )
else Order64 := Order32( Z.Lo );
end;
(**********************************************************)
(* MSB index ( return -1 for 0 ) *)
function Order32( Z : Int32 ) : integer;
var b : integer;
begin
b := 0;
while Z <> 0 do begin Z := Z shr 1; inc( b ); end;
Order32 := b-1;
end;
const
Roots : array[0..62] of LongInt
= (
1, 1, 2, 3, 4, 5, 8, 11,
16, 22, 32, 45, 64, 90, 128, 181,
256, 362, 512, 724, 1024, 1448, 2048, 2896,
4096, 5892, 8192, 11585, 16384, 23170, 32768, 46340,
65536, 92681, 131072, 185363, 262144, 370727,
524288, 741455, 1048576, 1482910, 2097152, 2965820,
4194304, 5931641, 8388608, 11863283, 16777216, 23726566,
33554432, 47453132, 67108864, 94906265,
134217728, 189812531, 268435456, 379625062,
536870912, 759250125, 1073741824, 1518500250,
2147483647
);
(**************************************************)
(* Integer Square Root *)
function Sqrt32( L : Int32 ): LongInt;
var
R, S : LongInt;
begin
if L<=0 then Sqrt32:=0 else
if L=1 then Sqrt32:=1 else
begin
R:=Roots[ Order32(L) ];
Repeat
S:=R;
R:=( R+ L div R ) shr 1;
until ( R <= S ) and ( R*R <= L );
Sqrt32:=R;
end;
end;
(**************************************************)
(* Integer Square Root *)
function Sqrt64( L : Int64 ): LongInt;
var
L2 : Int64;
R, S : LongInt;
begin
if L.Hi < 0 then Sqrt64:=0 else
begin
S := Order64(L);
if S = 0 then Sqrt64:=1 else
begin
R := Roots[S];
Repeat
S := R;
R := ( R+Div64by32(L,R) ) shr 1;
if ( R > S ) then continue;
MulTo64( R, R, L2 );
Sub64 ( L, L2, L2 );
until ( L2.Hi >= 0 );
Sqrt64 := R;
end
end
end;
end.

124
pascal/lib/ttcalc1.inc Normal file
View File

@@ -0,0 +1,124 @@
(*******************************************************************
*
* TTCalc1.Inc 1.3
*
* Arithmetic and Vectorial Computations (inline assembly)
* This version is used for 16-bit Turbo-Borland Pascal 6.0 & 7.0
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
* NOTES : All vector operations were moved to the interpreter
*
******************************************************************)
(**********************************************************)
(* *)
(* The following routines are inline assembly, they are *)
(* thus processor and bitness specific. Replace them *)
(* with your own if you want to port the TrueType Engine *)
(* We need unsigned longints to perform correctly our additions *)
(* we include inline assembly to get them, baaahhh .. *)
{**********************************************************}
{* 64 Bit Addition *}
procedure Add64( var X, Y, Z : Int64 ); assembler;
asm
les si,[X]
mov ax,es:[ si ].word
mov dx,es:[si+2].word
mov bx,es:[si+4].word
mov cx,es:[si+6].word
les si,[Y]
add ax,es:[ si ].word
adc dx,es:[si+2].word
adc bx,es:[si+4].word
adc cx,es:[si+6].word
les si,[Z]
mov es:[ si ].word,ax
mov es:[si+2].word,dx
mov es:[si+4].word,bx
mov es:[si+6].word,cx
end;
{**********************************************************}
{* 64 Bit Substraction *}
procedure Sub64( var X, Y, Z : Int64 ); assembler;
asm
les si,[X]
mov ax,es:[ si ].word
mov dx,es:[si+2].word
mov bx,es:[si+4].word
mov cx,es:[si+6].word
les si,[Y]
sub ax,es:[ si ].word
sbb dx,es:[si+2].word
sbb bx,es:[si+4].word
sbb cx,es:[si+6].word
les si,[Z]
mov es:[ si ].word,ax
mov es:[si+2].word,dx
mov es:[si+4].word,bx
mov es:[si+6].word,cx
end;
{**********************************************************}
{* Multiply two Int32 to an Int64 *}
procedure MulTo64( X, Y : Int32; var Z : Int64 ); assembler;
asm
les si,[Z]
db $66; mov ax,[X].word
db $66; imul [Y].word
db $66; mov es:[si],ax
db $66; mov es:[si+4],dx
end;
{**********************************************************}
{* Divide an Int64 by an Int32 *}
function Div64by32( var X : Int64; Y : Int32 ) : Int32; assembler;
asm
les si,[X]
db $66; mov ax,es:[si]
db $66; mov dx,es:[si+4]
db $66; idiv [Y].word
db $66; mov dx, ax
db $66; sar dx, 16
end;
procedure DivMod64by32( var X : Int64; Y : Int32; var Q, R : Int32 ); assembler;
asm
les si,[X]
db $66; mov ax,es:[si]
db $66; mov dx,es:[si+4]
db $66; idiv [Y].word
les si, [Q]
db $66; mov es:[si], ax
les si, [R]
db $66; mov es:[si], dx
end;

107
pascal/lib/ttcalc2.inc Normal file
View File

@@ -0,0 +1,107 @@
(*******************************************************************
*
* TTCalc2.Inc 1.2
*
* Arithmetic and Vectorial Computations (inline assembly)
* This version is used for the OS/2 Virtual Pascal compiler
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
* NOTES : All vector operations were moved to the interpreter
*
******************************************************************)
(**********************************************************)
(* *)
(* The following routines are inline assembly, they are *)
(* thus processor and bitness specific. Replace them *)
(* with your own if you want to port the TrueType Engine *)
(* We need unsigned longints to perform correctly our additions *)
(* we include inline assembly to get them, baaahhh .. *)
(**********************************************************)
(* 64 Bit Addition *)
procedure Add64( var X, Y, Z : Int64 ); assembler;
{&USES ebx, edx}
asm
mov ebx,[X].dword
mov eax,[ebx]
mov edx,[ebx+4]
mov ebx,[Y].dword
add eax,[ebx]
adc edx,[ebx+4]
mov ebx,[Z].dword
mov [ebx],eax
mov [ebx+4],edx
end;
(**********************************************************)
(* 64 Bit Substraction *)
procedure Sub64( var X, Y, Z : Int64 ); assembler;
{&USES ebx, edx}
asm
mov ebx,[X].dword
mov eax,[ebx]
mov edx,[ebx+4]
mov ebx,[Y].dword
sub eax,[ebx]
sbb edx,[ebx+4]
mov ebx,[Z].dword
mov [ebx],eax
mov [ebx+4],edx
end;
(**********************************************************)
(* Multiply two Int32 to an Int64 *)
procedure MulTo64( X, Y : Int32; var Z : Int64 ); assembler;
{&USES ebx, edx }
asm
mov ebx,[Z].dword
mov eax,[X]
imul dword ptr [Y]
mov [ebx],eax
mov [ebx+4],edx
end;
(**********************************************************)
(* Divide an Int64 by an Int32 *)
function Div64by32( var X : Int64; Y : Int32 ) : Int32; assembler;
{&USES ebx, edx}
asm
mov ebx, [X].dword
mov eax, [ebx]
mov edx, [ebx+4]
idiv dword ptr [Y]
end;
procedure DivMod64by32( var X : Int64; Y : Int32; var Q, R : Int32 );
assembler; {&USES ebx, edx}
asm
mov ebx, [X].dword
mov eax, [ebx]
mov edx, [ebx+4]
idiv dword ptr [Y]
mov ebx, [Q].dword
mov [ebx], eax
mov ebx, [R].dword
mov [ebx], edx
end;

99
pascal/lib/ttcalc3.inc Normal file
View File

@@ -0,0 +1,99 @@
(*******************************************************************
*
* TTCalc3.Inc 1.2
*
* Arithmetic and Vectorial Computations (inline assembly)
* This version is used for Delphi 2
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
* NOTES : All vector operations were moved to the interpreter
*
******************************************************************)
(**********************************************************)
(* *)
(* The following routines are inline assembly, they are *)
(* thus processor and bitness specific. Replace them *)
(* with your own if you want to port the TrueType Engine *)
(* NOTE : Delphi seems to use the eax, edx then ecx registers to pass *)
(* the first three parameters *)
(**********************************************************)
(* 64 Bit Addition *)
procedure Add64( var X, Y, Z : Int64 ); assembler;
asm
push ebx
push esi
mov ebx, [ eax ]
mov esi, [eax+4]
add ebx, [ edx ]
adc esi, [edx+4]
mov [ ecx ], ebx
mov [ecx+4], esi
pop esi
pop ebx
end;
(**********************************************************)
(* 64 Bit Substraction *)
procedure Sub64( var X, Y, Z : Int64 ); assembler;
asm
push ebx
push esi
mov ebx, [ eax ]
mov esi, [eax+4]
sub ebx, [ edx ]
sbb esi, [edx+4]
mov [ ecx ], ebx
mov [ecx+4], esi
pop esi
pop ebx
end;
(**********************************************************)
(* Multiply two Int32 to an Int64 *)
procedure MulTo64( X, Y : Int32; var Z : Int64 ); assembler;
asm
imul edx
mov [ ecx ],eax
mov [ecx+4],edx
end;
(**********************************************************)
(* Divide an Int64 by an Int32 *)
function Div64by32( var X : Int64; Y : Int32 ) : Int32; assembler;
asm
mov ecx, edx
mov edx, [eax+4].dword
mov eax, [ eax ].dword
idiv ecx
end;
procedure DivMod64by32( var X : Int64; Y : Int32; var Q, R : Int32 );
assembler;
asm
push ebx
mov ebx, edx
mov edx, [eax+4].dword
mov eax, [ eax ].dword
idiv ebx
mov [ecx], eax
mov ebx, R
mov [ebx], edx
pop ebx
end;

134
pascal/lib/ttcalc4.inc Normal file
View File

@@ -0,0 +1,134 @@
(*******************************************************************
*
* TTCalc4.Inc 1.2
*
* Arithmetic and Vectorial Computations (inline assembly)
* This version is used for i386 FreePascal
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
* NOTES : All vector operations were moved to the interpreter
*
******************************************************************)
(**********************************************************)
(* *)
(* The following routines are inline assembly, they are *)
(* thus processor and bitness specific. Replace them *)
(* with your own if you want to port the TrueType Engine *)
(**********************************************************)
(* 64 Bit Addition *)
procedure Add64( var X, Y, Z : Int64 ); assembler;
asm
push %ebx
push %edx
mov X,%ebx
mov (%ebx) ,%eax
mov 4(%ebx) ,%edx
mov Y,%ebx
add (%ebx) ,%eax
adc 4(%ebx) ,%edx
mov Z,%ebx
mov %eax, (%ebx)
mov %edx, 4(%ebx)
pop %edx
pop %ebx
end;
(**********************************************************)
(* 64 Bit Substraction *)
procedure Sub64( var X, Y, Z : Int64 ); assembler;
asm
push %ebx
push %edx
mov X,%ebx
mov (%ebx) ,%eax
mov 4(%ebx) ,%edx
mov Y,%ebx
sub (%ebx) ,%eax
sbb 4(%ebx) ,%edx
mov Z,%ebx
mov %eax, (%ebx)
mov %edx, 4(%ebx)
pop %edx
pop %ebx
end;
(**********************************************************)
(* Multiply two Int32 to an Int64 *)
procedure MulTo64( X, Y : Int32; var Z : Int64 ); assembler;
asm
push %ebx
push %edx
mov X,%eax
imull Y
mov Z,%ebx
mov %eax, (%ebx)
mov %edx, 4(%ebx)
pop %edx
pop %ebx
end;
(**********************************************************)
(* Divide an Int64 by an Int32 *)
function Div64by32( var X : Int64; Y : Int32 ) : Int32; assembler;
asm
push %ebx
push %edx
mov X,%ebx
mov (%ebx) ,%eax
mov 4(%ebx) ,%edx
idivl Y
pop %edx
pop %ebx
end;
procedure DivMod64by32( var X : Int64; Y : Int32; var Q, R : Int32 );
assembler;
asm
push %ebx
push %edx
mov X,%ebx
mov (%ebx) ,%eax
mov 4(%ebx) ,%edx
idivl Y
mov Q, %ebx
mov %eax, (%ebx)
mov R, %ebx
mov %edx, (%ebx)
pop %edx
pop %ebx
end;

431
pascal/lib/ttcmap.pas Normal file
View File

@@ -0,0 +1,431 @@
(*******************************************************************
*
* ttcmap.pas 1.0
*
* Character Mappings unit.
*
* Copyright 1996, 1997 by
* David Turner, Robert Wilhelm, and Werner Lemberg.
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
******************************************************************)
unit TTCMap;
interface
uses FreeType, TTTypes;
type
(********************************************************************)
(* *)
(* CHARACTER MAPPINGS SUBTABLES *)
(* *)
(********************************************************************)
(* FORMAT 0 *)
(* Apple standard character to glyph index mapping table *)
(* the glyphIdArray for this format has 256 entries *)
TCMap0 = record
glyphIdArray : PUShort;
end;
(* FORMAT 2 *)
(* the format 2 table contains a variable-length array of subHeaders *)
(* (at most 256 entries) whose size must be determined algorithmically *)
TCMap2SubHeader = record
firstCode : UShort; (* first valid low byte *)
entryCount : UShort; (* number of valid low bytes *)
idDelta : Short; (* delta value to glyphIndex *)
idRangeOffset : UShort; (* offset fr. here to 1stCode *)
end;
TCMap2SubHeaders = array[0..100] of TCMap2SubHeader;
PCMap2SubHeaders = ^TCMap2SubHeaders;
(* Format 2 is used for mixed 8/16bit encodings (usually CJK fonts) *)
TCMap2 = record
subHeaderKeys : PUShort;
(* high byte mapping table *)
(* value = subHeader index * 8 *)
subHeaders : PCMap2SubHeaders;
glyphIdArray : PUShort;
numGlyphId : Int;
end;
(* FORMAT 4 *)
(*The format 4 table contains segCount segments *)
TCMap4Segment = record
endCount : UShort;
startCount : UShort;
idDelta : UShort;
idRangeOffset : UShort;
end;
TCMap4Segments = array[0..100] of TCMap4Segment;
PCMap4Segments = ^TCMap4Segments;
(* Microsoft standard character to glyph index mapping table *)
TCMap4 = record
segCountX2 : UShort; (* segments number * 2 *)
searchRange : UShort; (* these parameters can be used *)
entrySelector : UShort; (* for a binary search *)
rangeShift : UShort;
segments : PCMap4Segments;
glyphIdArray : PUShort;
numGlyphId : Int;
end;
(* FORMAT 6 *)
(* trimmed table mapping (for representing one subrange) *)
TCMap6 = record
firstCode : UShort; (* first character code of subrange *)
entryCount : UShort; (* num. of character codes in subrange *)
glyphIdArray : PUShort;
end;
(* CHARMAP TABLE *)
PCMapTable = ^TCMapTable;
TCMapTable = record
platformID : UShort;
platformEncodingID : UShort;
Format : word;
Length : word;
Version : word;
Loaded : Boolean;
Offset : Long;
case Byte of
0 : ( cmap0 : TCMap0 );
2 : ( cmap2 : TCMap2 );
4 : ( cmap4 : TCMap4 );
6 : ( cmap6 : TCMap6 );
end;
TCMapTables = array[0..9] of TCMapTable;
PCMapTables = ^TCMapTables;
function CharMap_Load( var cmap : TCMapTable ) : TError;
procedure CharMap_Free( var cmap : TCMapTable );
function CharMap_Index( var cmap : TCMapTable; charCode : Long ) : UShort;
implementation
uses
TTError, TTMemory, TTFile;
function CharMap_Load( var cmap : TCMapTable ) : TError;
var
num_SH, u : UShort;
i : Int;
numGlyphId : Int;
num_segs : Int;
label
Fail;
begin
CharMap_Load := Failure;
if cmap.loaded then
begin
CharMap_Load := Success;
exit;
end;
if TT_Seek_File( cmap.offset ) then exit;
case cmap.format of
0: with cmap.cmap0 do
if Alloc( glyphIdArray, 256 ) or
TT_Read_File( glyphIdArray^, 256 ) then goto Fail;
2: begin
num_SH := 0;
with cmap.cmap2 do
begin
if Alloc( subHeaderKeys, 256*sizeof(UShort) ) or
TT_Access_Frame( 512 ) then goto Fail;
for i := 0 to 255 do
begin
u := GET_UShort shr 3;
subHeaderKeys^[i] := u;
if num_SH < u then num_SH := u;
end;
TT_Forget_Frame;
(* now load sub headers *)
numGlyphId := ((cmap.length - 2*(256+3) - num_SH*8) and $FFFF)
div 2;
if Alloc( subHeaders, (num_SH+1)*sizeof(TCMap2SubHeader) ) or
TT_Access_Frame( (num_SH+1)*8 ) then goto Fail;
for i := 0 to num_SH do with subHeaders^[i] do
begin
firstCode := GET_UShort;
entryCount := GET_UShort;
idDelta := GET_UShort;
(* we apply the location offset immediately *)
idRangeOffset := GET_UShort - (num_SH-i)*8 - 2;
end;
TT_Forget_Frame;
(* load glyph ids *)
if Alloc( glyphIdArray, numGlyphId*sizeof(UShort) ) or
TT_Access_Frame( numGlyphId*2 ) then goto Fail;
for i := 0 to numGlyphId-1 do
glyphIdArray^[i] := GET_UShort;
TT_Forget_Frame;
end;
end;
4: with cmap.cmap4 do
begin
if TT_Access_Frame(8) then goto Fail;
segCountX2 := Get_UShort;
searchRange := Get_UShort;
entrySelector := Get_UShort;
rangeShift := Get_UShort;
num_segs := segCountX2 shr 1;
TT_Forget_Frame;
(* load segments *)
if Alloc( segments, num_segs*sizeof(TCMap4Segment) ) or
TT_Access_Frame( (num_segs*4+1)*2 ) then goto Fail;
for i := 0 to num_segs-1 do
segments^[i].endCount := Get_UShort;
Get_UShort;
for i := 0 to num_segs-1 do
segments^[i].startCount := Get_UShort;
for i := 0 to num_segs-1 do
segments^[i].idDelta := GET_Short;
for i := 0 to num_segs-1 do
segments^[i].idRangeOffset := GET_UShort;
TT_Forget_Frame;
numGlyphId := (( cmap.length - (16+8*num_segs) ) and $FFFF)
div 2;
(* load glyph ids *)
if Alloc( glyphIdArray, numGlyphId*sizeof(UShort) ) or
TT_Access_Frame( numGlyphId*2 ) then goto Fail;
for i := 0 to numGlyphId-1 do
glyphIdArray^[i] := Get_UShort;
TT_Forget_Frame;
end;
6: with cmap.cmap6 do
begin
if TT_Access_Frame(4) then goto Fail;
firstCode := GET_UShort;
entryCount := GET_UShort;
TT_Forget_Frame;
if Alloc( glyphIdArray, entryCount*sizeof(Short) ) or
TT_Access_Frame( entryCount*2 ) then goto Fail;
for i := 0 to entryCount-1 do
glyphIdArray^[i] := GET_UShort;
TT_Forget_Frame;
end;
else
error := TT_Err_Invalid_Charmap_Format;
exit;
end;
CharMap_Load := success;
exit;
Fail:
CharMap_Free( cmap );
end;
procedure CharMap_Free( var cmap : TCMapTable );
begin
with cmap do
case format of
0 : begin
Free( cmap.cmap0.glyphIdArray );
end;
2 : begin
Free( cmap.cmap2.glyphIdArray );
Free( cmap.cmap2.subHeaders );
Free( cmap.cmap2.glyphIdArray );
end;
4 : begin
Free( cmap.cmap4.segments );
Free( cmap.cmap4.glyphIdArray );
cmap.cmap4.segCountX2 := 0;
end;
6 : begin
Free( cmap.cmap6.glyphIdArray );
cmap.cmap6.entryCount := 0;
end;
end;
cmap.loaded := False;
cmap.format := 0;
cmap.length := 0;
cmap.version := 0;
end;
function code_to_index0( charCode : UShort; var cmap0 : TCMap0 ) : UShort;
begin
code_to_index0 := 0;
if charCode < 256 then
code_to_index0 := cmap0.glyphIdArray^[charCode]
end;
function code_to_index2( charCode : UShort; var cmap2 : TCMap2 ) : UShort;
var
index1, idx, offset : UShort;
begin
code_to_index2 := 0;
if charCode < 256 then idx := charCode
else idx := charCode shr 8;
index1 := cmap2.subHeaderKeys^[idx];
if index1 = 0 then
begin
if charCode < 256 then
code_to_index2 := cmap2.glyphIdArray^[charCode]; (* 8Bit charcode *)
end
else
begin
if charCode < 256 then
exit;
idx := charCode and 255;
with cmap2.subHeaders^[index1] do
begin
if ( idx < firstCode ) or
( idx >= firstCode + entryCount ) then exit;
offset := idRangeOffset div 2 + idx - firstCode;
if offset >= cmap2.numGlyphId then exit;
idx := cmap2.glyphIdArray^[offset];
if idx <> 0 then
code_to_index2 := (idx + idDelta) and $FFFF;
end
end;
end;
function code_to_index4( charCode : UShort; var cmap4 : TCMap4 ) : UShort;
var
i, index1, num_segs : Int;
label
Found;
begin
code_to_index4 := 0;
num_segs := cmap4.segCountX2 div 2;
i := 0;
while ( i < num_segs ) do with cmap4.segments^[i] do
begin
if charCode <= endCount then goto Found;
inc(i);
end;
exit;
Found:
with cmap4.segments^[i] do
begin
if charCode < startCount then
exit;
if idRangeOffset = 0 then
code_to_index4 := (charCode + idDelta) and $FFFF
else
begin
index1 := idRangeOffset div 2 + (charCode - startCount) -
-(num_segs-i);
if ( index1 < cmap4.numGlyphId ) and
( cmap4.glyphIdArray^[index1] <> 0 ) then
code_to_index4 := (cmap4.glyphIdArray^[index1] + idDelta) and $FFFF;
end;
end;
end;
function code_to_index6( charCode : UShort; var cmap6 : TCMap6 ) : UShort;
begin
code_to_index6 := 0;
with cmap6 do
begin
if ( charCode < firstCode ) or
( charCode >= firstCode + entryCount ) then exit;
code_to_index6 := glyphIdArray^[charCode-firstCode];
end
end;
function CharMap_Index( var cmap : TCMapTable;
charCode : Long ) : UShort;
begin
CharMap_Index := 0;
case cmap.format of
0: CharMap_Index := code_to_index0( charCode, cmap.cmap0 );
2: CharMap_Index := code_to_index2( charCode, cmap.cmap2 );
4: CharMap_Index := code_to_index4( charCode, cmap.cmap4 );
6: CharMap_Index := code_to_index6( charCode, cmap.cmap6 );
end;
end;
end.

75
pascal/lib/ttconfig.inc Normal file
View File

@@ -0,0 +1,75 @@
(* *)
(* TTConfig.Inc *)
(* *)
(* This file contains several definition pragmas that are used to *)
(* build several versions of the library. Each constant is commented *)
(* Define the DEBUG constant if you want the library dumping trace *)
(* information to the standard error output. *)
{ $DEFINE DEBUG}
(* Define the ASSERT constant if you want to generate runtime integrity *)
(* checks within the library. Most of the checks will panic and stop the *)
(* the program when failed.. *)
{ $DEFINE ASSERT}
(* Define the INLINE constant if you want to use inlining when provided *)
(* by your compiler. Currently, only Virtual Pascal does *)
{$IFDEF VIRTUALPASCAL}
{$DEFINE INLINE}
{$ENDIF}
(* Define the USE32 constant on 32-bit systems. Virtual Pascal *)
(* always define it by default. Now set for Delphi 2 and 3 *)
{$IFDEF WIN32}
{$DEFINE USE32}
{$ENDIF}
(* FreeType doesn't compile on old Pascal compilers that do not allow *)
(* inline assembly like Turbo Pascal 5.5 and below *)
{$IFDEF VER50}
ERROR : FreeType cannot be compiled with something older than Turbo Pascal 6.0
{$ENDIF}
{$IFDEF VER55}
ERROR : FreeType cannot be compiled with something older than Turbo Pascal 6.0
{$ENDIF}
(* Define the BORLANDPASCAL constant whenever you're using a DOS-based *)
(* version of Turbo or Borland Pascal. *)
{$IFDEF VER60}
{$DEFINE BORLANDPASCAL}
{$ENDIF}
{$IFDEF VER70}
{$DEFINE BORLANDPASCAL}
{$ENDIF}
(* Define DELPHI16 when compiled in the 16_bit version of Delphi *)
{$IFDEF VER80}
{$DEFINE DELPHI16}
{$ENDIF}
(* Define DELPHI32 when compiled in any 32-bit version of Delphi *)
{$IFDEF VER90} (* for Delphi 2 *)
{$DEFINE DELPHI32}
{$ENDIF}
{$IFDEF VER100} (* for Delphi 3 *)
{$DEFINE DELPHI32}
{$ENDIF}
{$IFDEF VER110} (* for Borland C++ Builder 3 *)
{$DEFINE DELPHI32}
{$ENDIF}
{$IFDEF VER120} (* for Delphi 4 *)
{$DEFINE DELPHI32}
{$ENDIF}
{$IFDEF VER125} (* for Borland C++ Builder 4 *)
{$DEFINE DELPHI32}
{$ENDIF}
(* I don't have Delphi 5, I hope this will work *)
{$IFDEF VER130}
{$DEFINE DELPHI32}
{$ENDIF}

851
pascal/lib/ttdebug.pas Normal file
View File

@@ -0,0 +1,851 @@
(*******************************************************************
*
* TTDebug.Pas 1.2
*
* This unit is only used by the debugger.
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
******************************************************************)
unit TTDebug;
interface
uses TTTypes, TTTables, TTObjs, TTInterp;
type
ByteHexStr = string[2]; (* hex representation of a byte *)
ShortHexStr = string[4]; (* " " " short *)
LongHexStr = string[8]; (* " " " long *)
DebugStr = string[128]; (* disassembled line output *)
{ TBreakPoint }
{ A simple record to hold breakpoint information }
{ it may be completed later with pass count, etc.. }
{ They must be in a sorted linked list }
PBreakPoint = ^TBreakPoint;
TBreakPoint = record
Next : PBreakPoint;
Range : Int;
Address : Int;
end;
{ TRangeRec }
{ a record to store line number information and breakpoints list }
PRangeRec = ^TRangeRec;
TRangeRec = record
Code : PByte;
Size : Int;
index : Int;
NLines : Int;
Disassembled : PUShort;
Breaks : PBreakPoint;
end;
{ Generate_Range : Generate Line Number information specific to }
{ a given range }
procedure Generate_Range( CR : PCodeRange;
index : Int;
var RR : TRangeRec );
{ Throw_Range : Discard Line Number Information }
procedure Throw_Range( var RR : TRangeRec );
{ Toggle_Break : Toggle a breakpoint }
procedure Toggle_Break( var Head : PBreakPoint; Range, Adr : Int );
{ Set_Break : Set a breakpoint on a given address }
procedure Set_Break ( var Head : PBreakPoint; Range, Adr : Int );
{ Clear_Break : Clear one specific breakpoint }
procedure Clear_Break( var Head : PBreakPoint; Bp : PBreakPoint );
{ Clear_All_Breaks : Clear breakpoint list }
procedure Clear_All_Breaks( var Head : PBreakPoint );
{ Find_Breakpoint : find one breakpoint at a given address }
function Find_BreakPoint( Head : PBreakPoint; Range, IP : Int ) : PBreakPoint;
{ Cur_U_Line : returns the current disassembled line at Code(IP) }
function Cur_U_Line( Code : PByte; IP : Int ) : DebugStr;
{ Get_Length : returns the length of the current opcode at Code(IP) }
function Get_Length( Code : PByte; IP : Int ) : Int;
function Get_Dis_Line( var cr : TRangeRec; addr : Int ) : Int;
{ Hex_N : returns an hexadecimal string }
function Hex8 ( B : Byte ) : ByteHexStr;
function Hex16( W : word ) : ShortHexStr;
function Hex32( L : Long ) : LongHexStr;
implementation
type
PStorageLong = ^TStorageLong;
TStorageLong = record (* do-it-all union record type *)
case Byte of
0 : ( L : LongInt );
1 : ( S1, S2 : Integer );
2 : ( W1, W2 : Word );
3 : ( B1, B2,
B3, B4 : Byte );
4 : ( P : Pointer );
end;
var
OpSize : int;
const
OpStr : array[ 0..255 ] of String[10]
= (
'SVTCA y', (* Set vectors to coordinate axis y *)
'SVTCA x', (* Set vectors to coordinate axis x *)
'SPvTCA y', (* Set Proj. vec. to coord. axis y *)
'SPvTCA x', (* Set Proj. vec. to coord. axis x *)
'SFvTCA y', (* Set Free. vec. to coord. axis y *)
'SFvTCA x', (* Set Free. vec. to coord. axis x *)
'SPvTL //', (* Set Proj. vec. parallel to segment *)
'SPvTL +', (* Set Proj. vec. normal to segment *)
'SFvTL //', (* Set Free. vec. parallel to segment *)
'SFvTL +', (* Set Free. vec. normal to segment *)
'SPvFS', (* Set Proj. vec. from stack *)
'SFvFS', (* Set Free. vec. from stack *)
'GPV', (* Get projection vector *)
'GFV', (* Get freedom vector *)
'SFvTPv', (* Set free. vec. to proj. vec. *)
'ISECT', (* compute intersection *)
'SRP0', (* Set reference point 0 *)
'SRP1', (* Set reference point 1 *)
'SRP2', (* Set reference point 2 *)
'SZP0', (* Set Zone Pointer 0 *)
'SZP1', (* Set Zone Pointer 1 *)
'SZP2', (* Set Zone Pointer 2 *)
'SZPS', (* Set all zone pointers *)
'SLOOP', (* Set loop counter *)
'RTG', (* Round to Grid *)
'RTHG', (* Round to Half-Grid *)
'SMD', (* Set Minimum Distance *)
'ELSE', (* Else *)
'JMPR', (* Jump Relative *)
'SCvTCi', (* Set CVT *)
'SSwCi', (* *)
'SSW', (* *)
'DUP',
'POP',
'CLEAR',
'SWAP',
'DEPTH',
'CINDEX',
'MINDEX',
'AlignPTS',
'INS_$28',
'UTP',
'LOOPCALL',
'CALL',
'FDEF',
'ENDF',
'MDAP[-]',
'MDAP[r]',
'IUP[y]',
'IUP[x]',
'SHP[0]',
'SHP[1]',
'SHC[0]',
'SHC[1]',
'SHZ[0]',
'SHZ[1]',
'SHPIX',
'IP',
'MSIRP[0]',
'MSIRP[1]',
'AlignRP',
'RTDG',
'MIAP[-]',
'MIAP[r]',
'NPushB',
'NPushW',
'WS',
'RS',
'WCvtP',
'RCvt',
'GC[0]',
'GC[1]',
'SCFS',
'MD[0]',
'MD[1]',
'MPPEM',
'MPS',
'FlipON',
'FlipOFF',
'DEBUG',
'LT',
'LTEQ',
'GT',
'GTEQ',
'EQ',
'NEQ',
'ODD',
'EVEN',
'IF',
'EIF',
'AND',
'OR',
'NOT',
'DeltaP1',
'SDB',
'SDS',
'ADD',
'SUB',
'DIV',
'MUL',
'ABS',
'NEG',
'FLOOR',
'CEILING',
'ROUND[G]',
'ROUND[B]',
'ROUND[W]',
'ROUND[?]',
'NROUND[G]',
'NROUND[B]',
'NROUND[W]',
'NROUND[?]',
'WCvtF',
'DeltaP2',
'DeltaP3',
'DeltaC1',
'DeltaC2',
'DeltaC3',
'SROUND',
'S45Round',
'JROT',
'JROF',
'ROFF',
'INS_$7B',
'RUTG',
'RDTG',
'SANGW',
'AA',
'FlipPT',
'FlipRgON',
'FlipRgOFF',
'INS_$83',
'INS_$84',
'ScanCTRL',
'SDPVTL[0]',
'SDPVTL[1]',
'GetINFO',
'IDEF',
'ROLL',
'MAX',
'MIN',
'ScanTYPE',
'IntCTRL',
'INS_$8F',
'INS_$90',
'INS_$91',
'INS_$92',
'INS_$93',
'INS_$94',
'INS_$95',
'INS_$96',
'INS_$97',
'INS_$98',
'INS_$99',
'INS_$9A',
'INS_$9B',
'INS_$9C',
'INS_$9D',
'INS_$9E',
'INS_$9F',
'INS_$A0',
'INS_$A1',
'INS_$A2',
'INS_$A3',
'INS_$A4',
'INS_$A5',
'INS_$A6',
'INS_$A7',
'INS_$A8',
'INS_$A9',
'INS_$AA',
'INS_$AB',
'INS_$AC',
'INS_$AD',
'INS_$AE',
'INS_$AF',
'PushB[0]',
'PushB[1]',
'PushB[2]',
'PushB[3]',
'PushB[4]',
'PushB[5]',
'PushB[6]',
'PushB[7]',
'PushW[0]',
'PushW[1]',
'PushW[2]',
'PushW[3]',
'PushW[4]',
'PushW[5]',
'PushW[6]',
'PushW[7]',
'MDRP[G]',
'MDRP[B]',
'MDRP[W]',
'MDRP[?]',
'MDRP[rG]',
'MDRP[rB]',
'MDRP[rW]',
'MDRP[r?]',
'MDRP[mG]',
'MDRP[mB]',
'MDRP[mW]',
'MDRP[m?]',
'MDRP[mrG]',
'MDRP[mrB]',
'MDRP[mrW]',
'MDRP[mr?]',
'MDRP[pG]',
'MDRP[pB]',
'MDRP[pW]',
'MDRP[p?]',
'MDRP[prG]',
'MDRP[prB]',
'MDRP[prW]',
'MDRP[pr?]',
'MDRP[pmG]',
'MDRP[pmB]',
'MDRP[pmW]',
'MDRP[pm?]',
'MDRP[pmrG]',
'MDRP[pmrB]',
'MDRP[pmrW]',
'MDRP[pmr?]',
'MIRP[G]',
'MIRP[B]',
'MIRP[W]',
'MIRP[?]',
'MIRP[rG]',
'MIRP[rB]',
'MIRP[rW]',
'MIRP[r?]',
'MIRP[mG]',
'MIRP[mB]',
'MIRP[mW]',
'MIRP[m?]',
'MIRP[mrG]',
'MIRP[mrB]',
'MIRP[mrW]',
'MIRP[mr?]',
'MIRP[pG]',
'MIRP[pB]',
'MIRP[pW]',
'MIRP[p?]',
'MIRP[prG]',
'MIRP[prB]',
'MIRP[prW]',
'MIRP[pr?]',
'MIRP[pmG]',
'MIRP[pmB]',
'MIRP[pmW]',
'MIRP[pm?]',
'MIRP[pmrG]',
'MIRP[pmrB]',
'MIRP[pmrW]',
'MIRP[pmr?]'
);
const
HexStr : string[16] = '0123456789abcdef';
(*******************************************************************
*
* Function : Hex8
*
* Description : Returns the string hexadecimal representation
* of a Byte.
*
* Input : B byte
*
* Output : two-chars string
*
*****************************************************************)
function Hex8( B : Byte ) : ByteHexStr;
var
S : ByteHexStr;
begin
S[0] :=#2;
S[1] := HexStr[ 1+( B shr 4 ) ];
S[2] := HexStr[ 1+( B and 15 )];
Hex8 := S;
end;
(*******************************************************************
*
* Function : Hex16
*
* Description : Returns the string hexadecimal representation
* of a Short.
*
* Input : W word
*
* Output : four-chars string
*
*****************************************************************)
function Hex16( W : word ) : ShortHexStr;
begin
Hex16 := Hex8( Hi(w) )+Hex8( Lo(w) );
end;
(*******************************************************************
*
* Function : Hex32
*
* Description : Returns the string hexadecimal representation
* of a Long.
*
* Input : L Long
*
* Output : eight-chars string
*
*****************************************************************)
function Hex32( L : Long ) : LongHexStr;
begin
Hex32 := Hex16( TStorageLong(L).W2 )+Hex16( TStorageLong(L).W1 );
end;
(*******************************************************************
*
* Function : Cur_U_Line
*
* Description : Returns a string of the current unassembled
* line at Code^[IP].
*
* Input : Code base code range
* IP current instruction pointer
*
* Output : line string
*
*****************************************************************)
function Cur_U_Line( Code : PByte; IP : Int ) : DebugStr;
var
Op : Byte;
N, I : Int;
S : DebugStr;
begin
Op := Code^[IP];
S := Hex16(IP)+': '+Hex8(Op)+' '+OpStr[Op];
case Op of
$40 : begin
n := Code^[IP+1];
S := S+'('+Hex8(n)+')';
for i := 1 to n do
S := S+' $'+Hex8( Code^[Ip+i+1] );
end;
$41 : begin
n := Code^[IP+1];
S := S+'('+Hex8(n)+')';
for i := 1 to n do
S := S+' $'+Hex8( Code^[Ip+i*2+1] )+Hex8( Code^[Ip+i*2+2] );
end;
$B0..$B7 : begin
n := Op-$B0;
for i := 0 to N do
S := S+' $'+Hex8( Code^[Ip+i+1] );
end;
$B8..$BF : begin
n := Op-$B8;
for i := 0 to N do
S := S+' $'+Hex8( Code^[IP+i*2+1] )+Hex8( Code^[Ip+i*2+2] );
end;
end;
Cur_U_Line := S;
end;
(*******************************************************************
*
* Function : Get_Length
*
* Description : Returns the length in bytes of the instruction at
* current instruction pointer.
*
* Input : Code base code range
* IP current instruction pointer
*
* Output : Length in bytes
*
*****************************************************************)
function Get_Length( Code : PByte; IP : Int ) : Int;
var
Op : Byte;
N : Int;
begin
Op := Code^[IP];
case Op of
$40 : N := 2 + Code^[IP+1];
$41 : N := 2 + Code^[IP+1]*2;
$B0..$B7 : N := 2 + ( Op-$B0 );
$B8..$BF : N := 3 + ( Op-$B8 )*2
else
N := 1;
end;
Get_Length := N;
end;
(*******************************************************************
*
* Function : Generate_Range
*
* Description : Create a list of unassembled lines for a
* given code range
*
* Input :
*
* Output :
*
*****************************************************************)
procedure Generate_Range( CR : PCodeRange;
index : Int;
var RR : TRangeRec );
var
Adr, Line, N : Int;
Code : PByte;
begin
N := CR^.Size;
RR.Code := PByte( CR^.Base );
RR.Size := N;
Line := 0;
if N > 0 then
begin
Adr := 0;
GetMem( RR.Disassembled, sizeof(Short) * N );
while Adr < N do
begin
RR.Disassembled^[Line] := Adr;
inc( Line );
inc( Adr, Get_Length( RR.Code, Adr ));
end;
end;
RR.NLines := Line;
RR.Index := index;
RR.Breaks := nil;
end;
(*******************************************************************
*
* Function : Get_Dis_Line
*
* Description : Returns the line index of address 'addr'
* in the coderange 'cr'
*
*****************************************************************)
function Get_Dis_Line( var cr : TRangeRec; addr : Int ) : Int;
var
l, r, m : Int;
begin
if (cr.NLines = 0) or
(addr > cr.Disassembled^[cr.Nlines-1] ) then
begin
Get_Dis_Line := -1;
exit;
end;
l := 0;
r := cr.NLines-1;
while ( r-l > 1 ) do
begin
if cr.Disassembled^[l] = addr then
begin
Get_Dis_Line := l;
exit;
end;
if cr.Disassembled^[r] = addr then
begin
Get_Dis_Line := r;
exit;
end;
m := (l+r) shr 1;
if cr.Disassembled^[m] = addr then
begin
Get_Dis_Line := m;
exit;
end
else
if cr.Disassembled^[m] < addr then
l := m
else
r := m;
end;
if cr.Disassembled^[r] = addr then
begin
Get_Dis_Line := r;
exit;
end;
Get_Dis_Line := l;
end;
(*******************************************************************
*
* Function : Throw_Range
*
* Description : Destroys a list of unassembled lines for a
* given code range
*
* Input :
*
* Output :
*
*****************************************************************)
procedure Throw_Range( var RR : TRangeRec );
var
B, Bnext : PBreakPoint;
begin
if RR.Size > 0 then
FreeMem( RR.Disassembled, RR.Size * sizeof(Short) );
RR.Disassembled := nil;
RR.Size := 0;
RR.Code := nil;
RR.NLines := 0;
B := RR.Breaks;
RR.Breaks := nil;
while B<>nil do
begin
Bnext := B^.Next;
Dispose( B );
B := Bnext;
end;
end;
(*******************************************************************
*
* Function : Set_Break
*
* Description : Sets a Breakpoint ON
*
* Input :
*
* Output :
*
*****************************************************************)
procedure Set_Break( var Head : PBreakPoint;
Range : Int;
Adr : Int );
var
BP,
Old,
Cur : PBreakPoint;
begin
Old := nil;
Cur := Head;
while (Cur <> nil) and (Cur^.Address < Adr) do
begin
Old := Cur;
Cur := Cur^.Next;
end;
{ No duplicates }
if Cur <> nil then
if (Cur^.Address = Adr) and (Cur^.Range = Range) then exit;
New( BP );
BP^.Address := Adr;
BP^.Range := Range;
BP^.Next := Cur;
if Old = nil then
Head := BP
else
Old^.Next := BP;
end;
(*******************************************************************
*
* Function : Clear_Break
*
* Description : Clears a breakpoint OFF
*
* Input :
*
* Output :
*
*****************************************************************)
procedure Clear_Break( var Head : PBreakPoint; Bp : PBreakPoint );
var
Old,
Cur : PBreakPoint;
begin
Old := nil;
Cur := Head;
while (Cur <> nil) and (Cur <> Bp) do
begin
Old := Cur;
Cur := Cur^.Next;
end;
if Cur = nil then exit;
if Old = nil then
Head := Cur^.Next
else
Old^.Next := Cur^.Next;
end;
procedure Toggle_Break( var Head : PBreakPoint; Range, Adr : Int );
var
Bp : PBreakPoint;
begin
Bp := Find_BreakPoint( Head, Range, Adr );
if Bp <> nil then Clear_Break( Head, Bp )
else Set_Break( Head, Range, Adr );
end;
(*******************************************************************
*
* Function : Clear_All_Breaks
*
* Description : Clears all breakpoints
*
* Input :
*
* Output :
*
*****************************************************************)
procedure Clear_All_Breaks( var Head : PBreakPoint );
var
Old,
Cur : PBreakPoint;
begin
Cur := Head;
Head := Nil;
while Cur <> nil do
begin
Old := Cur;
Cur := Cur^.Next;
Dispose( Old );
end;
end;
(*******************************************************************
*
* Function : Find_BreakPoint
*
* Description : Find a breakpoint at address IP
*
* Input : Head break points sorted linked list
* IP address of expected breakpoint
*
* Output : pointer to breakpoint if found
* nil otherwise.
*
*****************************************************************)
function Find_BreakPoint( Head : PBreakPoint; Range, IP : Int ) : PBreakPoint;
var
Cur : PBreakPoint;
Res : PBreakPoint;
begin
Cur := Head;
Res := nil;
while Cur <> nil do
begin
if (Cur^.Address = IP ) and
(Cur^.Range = Range) then Res := Cur;
if (Cur^.Address >= IP) then Cur := nil
else Cur := Cur^.Next;
end;
Find_BreakPoint := Res;
end;
end.

69
pascal/lib/tterror.pas Normal file
View File

@@ -0,0 +1,69 @@
(*******************************************************************
*
* tterror.pas 1.0
*
* Simple Error management unit
*
* Copyright 1996, 1997 by
* David Turner, Robert Wilhelm, and Werner Lemberg.
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
******************************************************************)
unit TTError;
interface
uses FreeType;
procedure Check_Error( error : Integer );
procedure Panic1( message : String );
procedure Trace1( message : String );
(* The Pascal version of the library doesn't support multiple *)
(* threads. We use a global error variable, called simply "error" *)
(* to report all defects. The various functions return an error *)
(* condition, which can be either Success (false) or Failure (true) *)
(* Note that the use of macros in the C version to automate error *)
(* reporting makes the two source trees very similar, even if they *)
(* differ from some design points like this one *)
var
error : integer;
implementation
procedure Panic1( message : String );
begin
writeln( message );
halt(1);
end;
procedure Trace1( message : String );
begin
writeln( message );
end;
procedure Check_Error( error : Integer );
var
num : String[4];
begin
if error <> TT_Err_Ok then
begin
str( -error:3, num );
Panic1( 'Error code = ' + num );
end;
end;
end.

979
pascal/lib/ttfile.pas Normal file
View File

@@ -0,0 +1,979 @@
(*******************************************************************
*
* TTFile.Pas 1.2
*
* File I/O Component (specification)
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
* NOTES :
*
*
* Changes from 1.1 to 1.2 :
*
* - Changes the stream operations semantics. See changes.txt
*
* - stream records are now allocated on demand in the heap
*
* - introduced the 'frame cache' to avoid Allocating/Freeing
* each frame, even tiny ones..
*
* - support for thread-safety and re-entrancy
*
* ( re-entrancy is there for information only.. )
*
* Changes from 1.0 to 1.1 :
*
* - defined the type TT_Stream for file handles
* - renamed ( and cleaned ) the API.
*
* - caching and memory-mapped files use the same API :
*
* TT_Access_Frame to notify
*
* - only the interface was really rewritten. This component still
* only supports one opened file at a time.
*
******************************************************************)
Unit TTFile;
interface
{$I TTCONFIG.INC}
uses FreeType,
TTTypes,
TTError;
function TTFile_Init : TError;
procedure TTFile_Done;
(*********************************************************************)
(* *)
(* Stream Functions *)
(* *)
(*********************************************************************)
function TT_Open_Stream( name : String;
var stream : TT_Stream ) : TError;
(* Open a file and return a stream handle for it *)
(* should only be used for a new typeface object's main stream *)
procedure TT_Close_Stream( var stream : TT_Stream );
(* closes, then discards a stream, when it becomes unuseful *)
(* should only be used for a typeface object's main stream *)
function TT_Use_Stream( org_stream : TT_Stream;
var stream : TT_Stream ) : TError;
(* notices the component that we're going to use the file *)
(* opened in 'org_stream', and report errors to the 'error' *)
(* variable. the 'stream' variable is untouched, except in *)
(* re-entrant buids. *)
(* in re-entrant builds, the original file handle is duplicated *)
(* to a new stream which reference is passed to the 'stream' *)
(* variable.. thus, each thread can have its own file cursor to *)
(* access the same file concurrently.. *)
procedure TT_Flush_Stream( stream : TT_Stream );
(* closes a stream's font handle. This is useful to save *)
(* system resources. *)
procedure TT_Done_Stream( stream : TT_Stream );
(* notice the file component that we don't need to perform *)
(* file ops on the stream 'stream' anymore.. *)
(* *)
(* in re-entrant builds, should also discard the stream *)
(*********************************************************************)
(* *)
(* File Functions *)
(* *)
(* the following functions perform file operations on the *)
(* currently 'used' stream. In thread-safe builds, only one *)
(* stream can be used at a time. Synchronisation is performed *)
(* through the Use_Stream/Done_Stream functions *)
(* *)
(* Note: *)
(* re-entrant versions of these functions are only available *)
(* in the C source tree. There, a macro is used to add a 'stream' *)
(* parameter to each of these routines.. *)
(* *)
(*********************************************************************)
function TT_Read_File( var ABuff; ACount : Int ) : TError;
(* Read a chunk of bytes directly from the file *)
function TT_Seek_File( APos : LongInt ) : TError;
(* Seek a new file position *)
function TT_Skip_File( ADist : LongInt ) : TError;
(* Skip to a new file position *)
function TT_Read_At_File( APos : Long; var ABuff; ACount : Int ) : TError;
(* Seek and read a chunk of bytes *)
function TT_File_Size : Longint;
function TT_File_Pos : Longint;
function TT_Stream_Size( stream : TT_Stream ) : longint;
(*********************************************************************)
(* *)
(* Frame Functions *)
(* *)
(*********************************************************************)
function TT_Access_Frame( aSize : Int ) : TError;
(* Access the next aSize bytes *)
function TT_Check_And_Access_Frame( aSize : Int ) : TError;
(* Access the next min(aSize,file_size-file_pos) bytes *)
function TT_Forget_Frame : TError;
(* Forget the previously cached frame *)
(* The four following functions should only be used after a *)
(* TT_Access_Frame and before a TT_Forget_Frame *)
(* They do not provide error handling, intentionnaly, and are much faster *)
(* moreover, they could be converted to MACROS in the C version *)
function GET_Byte : Byte;
function GET_Char : ShortInt;
function GET_Short : Short;
function GET_UShort : UShort;
function GET_Long : Long;
function GET_ULong : ULong;
function GET_Tag4 : ULong;
implementation
uses
TTMemory;
(* THREADS: TTMutex, *)
const
frame_cache_size = 2048;
(* we allocate a single block where we'll place all of our frames *)
(* instead of allocating an new block on each access. Note that *)
(* frames that are bigger than this constant are effectively *)
(* allocated in the heap.. *)
type
PString = ^string;
PFile = ^FILE;
PError = ^TT_Error;
PStream_Rec = ^TStream_Rec;
TStream_Rec = record
name : PString; (* file pathname *)
open : Boolean; (* is the stream currently opened *)
font : PFILE; (* file handle for opened stream *)
base : Longint; (* base offset for embedding *)
size : Longint; (* size of font in resource *)
posit : Longint; (* current offset for closed streams *)
end;
var
(* THREADS: File_Mutex : TMutex *)
font_file : PFile;
cur_stream : PStream_Rec;
current_frame : PByte;
frame_cursor : Longint;
frame_size : LongInt;
dummy_error : TT_Error;
frame_cache : PByte;
function TT_File_Size : Longint;
begin
TT_File_Size := FileSize( font_file^ );
end;
function TT_File_Pos : Longint;
begin
TT_File_Pos := FilePos( font_file^ );
end;
function TT_Stream_Size( stream : TT_Stream ) : longint;
var
rec : PStream_Rec;
begin
rec := PStream_Rec(stream);
if rec = nil then
TT_Stream_Size := 0
else
TT_Stream_Size := rec^.size;
end;
(*******************************************************************
*
* Function : TTFile_Init
*
* Description : Init the file component
*
* - create a file mutex for thread-safe builds
*
******************************************************************)
function TTFile_Init : TError;
begin
(* empty current file *)
font_file := nil;
cur_stream := nil;
(* empty frame *)
current_frame := nil;
frame_cursor := 0;
frame_size := 0;
(* create frame cache *)
GetMem( frame_cache, frame_cache_size );
TTFile_Init := Success;
end;
(*******************************************************************
*
* Function : TTFile_Done
*
* Description : Finalize the file component
*
* - destroys the file mutex for thread-safe builds
*
******************************************************************)
procedure TTFile_Done;
begin
(* empty current file *)
font_file := nil;
cur_stream := nil;
(* empty frame *)
current_frame := nil;
frame_cursor := 0;
frame_size := 0;
end;
(*******************************************************************
*
* Function : Stream_New
*
* Description : allocates a new stream record
*
* Input : stream : the target stream variable
*
* Output : True on sucess.
*
******************************************************************)
function Stream_New( pathname : string;
var stream : PStream_Rec ) : TError;
var
font : PFile;
name : PString;
len : Integer;
label
Fail_Memory;
begin
name := nil;
font := nil;
stream := nil;
len := length(pathname)+1;
(* allocate a new stream_rec in the heap *)
if Alloc( pointer(stream), sizeof(TStream_Rec) ) or
Alloc( pointer(font), sizeof(FILE) ) or
Alloc( pointer(name), len ) then
goto Fail_Memory;
move( pathname, name^, len );
stream^.font := font;
stream^.name := name;
stream^.open := false;
stream^.base := 0;
stream^.size := 0;
stream^.posit := 0;
Stream_New := Success;
exit;
Fail_Memory:
Free( pointer(name) );
Free( pointer(font) );
Free( pointer(stream) );
Stream_New := Failure;
end;
(*******************************************************************
*
* Function : Stream_Activate
*
* Description : activates a stream, if it needs it
*
* Input : stream : the target stream variable
*
* Output : Error condition
*
******************************************************************)
function Stream_Activate( stream : PStream_Rec ) : TError;
var
old_filemode : Long;
begin
Stream_Activate := Failure;
if stream = nil then exit;
with stream^ do
begin
Stream_Activate := Success;
if open then exit;
old_filemode := System.FileMode;
System.FileMode := 0;
(* read-only mode *)
Assign( font^, name^ );
{$I-}
Reset( font^, 1 );
{$I+}
System.FileMode := old_filemode;
if IOResult <> 0 then
begin
error := TT_Err_Could_Not_Open_File;
Stream_Activate := Failure;
exit;
end;
open := true;
base := 0;
if size = -1 then size := FileSize(font^);
if posit <> 0 then
Seek( font^, posit );
end;
end;
(*******************************************************************
*
* Function : Stream_Deactivate
*
* Description : closes an active stream
*
* Input : stream : the target stream variable
*
* Output : Error condition
*
******************************************************************)
function Stream_Deactivate( stream : PStream_Rec ) : TError;
begin
Stream_Deactivate := Failure;
if stream = nil then exit;
Stream_Deactivate := Success;
if not stream^.open then exit;
stream^.posit := FilePos( stream^.font^ );
close( stream^.font^ );
stream^.open := false;
end;
(*******************************************************************
*
* Function : Stream_Done
*
* Description : frees an active stream_rec
*
* Input : stream : the target stream variable
*
* Output : True on sucess.
*
* Notes : 'stream' is set to nil on exit..
*
******************************************************************)
function Stream_Done( var stream : PStream_Rec ) : TError;
begin
Stream_Deactivate( stream );
Free( pointer(stream^.name) );
Free( pointer(stream^.font) );
Free( pointer(stream) );
Stream_Done := Success;
end;
(*******************************************************************
*
* Function : TT_Open_Stream
*
* Description : opens the font file in a new stream
*
* Input : stream : target stream variable
* name : file pathname
* error : the variable that will be used to
* report stream errors
*
* Output : True on sucess.
*
******************************************************************)
function TT_Open_Stream( name : String;
var stream : TT_Stream ) : TError;
var
rec : PStream_Rec;
font : PFile;
old_filemode : Long;
begin
TT_Open_Stream := Failure;
if Stream_New( name, rec ) or
Stream_Activate( rec ) then
begin
stream.z := nil;
exit;
end;
cur_stream := rec;
font_file := rec^.font;
stream := TT_Stream(rec);
TT_Open_Stream := Success;
end;
(*******************************************************************
*
* Function : TT_Close_Stream
*
* Description : Closes the font file and releases memory buffer
*
* Input : None
*
* Output : True ( always )
*
******************************************************************)
procedure TT_Close_Stream( var stream : TT_Stream );
begin
if stream.z = nil then exit;
Stream_Done( PStream_Rec(stream) );
font_file := nil;
cur_stream := nil;
stream.z := nil;
end;
(*******************************************************************
*
* Function : TT_Use_Stream
*
* Description : Acquire the file mutex (blocking call)
*
* Input : org_stream : original stream to use
* stream : duplicate stream (in re-entrant builds)
* set to 'org_stream' otherwise
* error : error report variable
*
* Output : True on success. False on failure
*
******************************************************************)
function TT_Use_Stream( org_stream : TT_Stream;
var stream : TT_Stream ) : TError;
var
rec : PStream_Rec;
begin
TT_Use_Stream := Failure;
stream := org_stream;
if org_stream.z = nil then exit;
rec := PStream_Rec(stream);
Stream_Activate(rec);
cur_stream := rec;
font_file := rec^.font;
TT_Use_Stream := Success;
end;
(*******************************************************************
*
* Function : TT_Flush_Stream
*
* Description : closes a stream
*
* Input : stream : the stream
*
* Output : True on success. False on failure
*
******************************************************************)
procedure TT_Flush_Stream( stream : TT_Stream );
begin
if stream.Z <> nil then
Stream_Deactivate( PStream_Rec(stream.z) );
end;
(*******************************************************************
*
* Function : TT_Done_Stream
*
* Description : Release the file mutex on a stream
*
* Input : stream : the stream
*
* Output : True on success. False on failure
*
******************************************************************)
procedure TT_Done_Stream( stream : TT_Stream );
begin
if stream.z <> cur_stream then exit;
cur_stream := nil;
font_file := nil;
end;
(*******************************************************************
*
* Function : TT_Seek_File
*
* Description : Seek the file cursor to a different position
*
* Input : APos new position on file
*
* Output : True on success. False if out of range
*
* Notes : Does not set the error variable
*
******************************************************************)
function TT_Seek_File( APos : LongInt ) : TError;
begin
{$I-}
Seek( Font_File^, APos );
{$I+}
if IOResult <> 0 then
begin
error := TT_Err_Invalid_File_Offset;
TT_Seek_File := Failure;
exit;
end;
TT_Seek_File := Success;
end;
(*******************************************************************
*
* Function : TT_Skip_File
*
* Description : Skip forward the file cursor
*
* Input : ADist number of bytes to skip
*
* Output : see Seek_Font_File
*
******************************************************************)
function TT_Skip_File( ADist : LongInt ) : TError;
begin
TT_Skip_File := TT_Seek_File( FilePos(Font_File^)+ADist );
end;
(*******************************************************************
*
* Function : TT_Read_File
*
* Description : Reads a chunk of the file and copy it to memory
*
* Input : ABuff target buffer
* ACount length in bytes to read
*
* Output : True if success. False if out of range
*
* Notes : Current version prints an error message even if the
* debug state isn't on.
*
******************************************************************)
function TT_Read_File( var ABuff; ACount : Int ) : TError;
begin
TT_Read_File := Failure;
{$I-}
BlockRead( Font_File^, ABuff, ACount );
{$I+}
if IOResult <> 0 then
begin
error := TT_Err_Invalid_File_Read;
exit;
end;
TT_Read_File := Success;
end;
(*******************************************************************
*
* Function : TT_Read_At_File
*
* Description : Read file at a specified position
*
* Input : APos position to seek to before read
* ABuff target buffer
* ACount number of bytes to read
*
* Output : True on success. False if error.
*
* Notes : prints an error message if seek failed.
*
******************************************************************)
function TT_Read_At_File( APos : Long; var ABuff; ACount : Int ) : TError;
begin
TT_Read_At_File := Failure;
if TT_Seek_File( APos ) or
TT_Read_File( ABuff, ACount ) then exit;
TT_Read_At_File := Success;
end;
(*******************************************************************
*
* Function : TT_Access_Frame
*
* Description : Notifies the component that we're going to read
* aSize bytes from the current file position.
* This function should load/cache/map these bytes
* so that they will be addressed by the GET_xxx
* functions easily.
*
* Input : aSize number of bytes to access.
*
* Output : True on success. False on failure
*
* The function fails is the byte range is not within the
* the file, or if there is not enough memory to cache
* the bytes properly ( which usually means that aSize is
* too big in both cases ).
*
* It will also fail if you make two consecutive calls
* to TT_Access_Frame, without a TT_Forget_Frame between
* them.
*
******************************************************************)
function TT_Access_Frame( aSize : Int ) : TError;
var
readBytes : Longint;
begin
TT_Access_Frame := Failure;
if current_frame <> nil then
begin
error := TT_Err_Nested_Frame_Access;
exit;
end;
(* We already are accessing one frame *)
if aSize > frame_cache_size then
GetMem( current_frame, aSize )
else
current_frame := frame_cache;
if TT_Read_File( current_frame^, aSize ) then
begin
if aSize > frame_cache_size then
FreeMem( current_frame, aSize );
current_frame := nil;
exit;
end;
frame_size := aSize;
frame_cursor := 0;
TT_Access_Frame := Success;
end;
(*******************************************************************
*
* Function : TT_Check_And_Access_Frame
*
* Description : Notifies the component that we're going to read
* aSize bytes from the current file position.
* This function should load/cache/map these bytes
* so that they will be addressed by the GET_xxx
* functions easily.
*
* Input : aSize number of bytes to access.
*
* Output : True on success. False on failure
*
* The function fails is the byte range is not within the
* the file, or if there is not enough memory to cache
* the bytes properly ( which usually means that aSize is
* too big in both cases ).
*
* It will also fail if you make two consecutive calls
* to TT_Access_Frame, without a TT_Forget_Frame between
* them.
*
*
* NOTE : The only difference with TT_Access_Frame is that we check
* that the frame is within the current file. We otherwise
* truncate it..
*
******************************************************************)
function TT_Check_And_Access_Frame( aSize : Int ) : TError;
var
readBytes : Longint;
begin
TT_Check_And_Access_Frame := Failure;
if current_frame <> nil then
begin
error := TT_Err_Nested_Frame_Access;
exit;
end;
(* We already are accessing one frame *)
readBytes := TT_File_Size - TT_File_Pos;
if aSize > readBytes then aSize := readBytes;
if aSize > frame_cache_size then
GetMem( current_frame, aSize )
else
current_frame := frame_cache;
if TT_Read_File( current_frame^, aSize ) then
begin
if aSize > frame_cache_size then
FreeMem( current_frame, aSize );
exit;
end;
frame_size := aSize;
frame_cursor := 0;
TT_Check_And_Access_Frame := Success;
end;
(*******************************************************************
*
* Function : TT_Forget_Frame
*
* Description : Releases a cached frame after reading
*
* Input : None
*
* Output : True on success. False on failure
*
******************************************************************)
function TT_Forget_Frame : TError;
begin
TT_Forget_Frame := Failure;
if current_frame = nil then exit;
if frame_size > frame_cache_size then
FreeMem( current_frame, frame_size );
frame_size := 0;
current_frame := nil;
frame_cursor := 0;
end;
(*******************************************************************
*
* Function : GET_Byte
*
* Description : Extracts a byte from the current file frame
*
* Input : None
*
* Output : Extracted Byte.
*
* NOTES : We consider that the programmer is intelligent enough
* not to try to get a byte that is out of the frame. Hence,
* we provide no bounds check here. (A misbehaving client
* could easily page fault using this call).
*
******************************************************************)
function GET_Byte : Byte;
begin
GET_Byte := current_frame^[frame_cursor];
inc( frame_cursor );
end;
(*******************************************************************
*
* Function : GET_Char
*
* Description : Extracts a signed byte from the current file frame
*
* Input : None
*
* Output : Extracted char.
*
* NOTES : We consider that the programmer is intelligent enough
* not to try to get a byte that is out of the frame. Hence,
* we provide no bounds check here. (A misbehaving client
* could easily page fault using this call).
*
******************************************************************)
function GET_Char : ShortInt;
begin
GET_Char := ShortInt( current_frame^[frame_cursor] );
inc( frame_cursor );
end;
(*******************************************************************
*
* Function : GET_Short
*
* Description : Extracts a short from the current file frame
*
* Input : None
*
* Output : Extracted short.
*
* NOTES : We consider that the programmer is intelligent enough
* not to try to get a byte that is out of the frame. Hence,
* we provide no bounds check here. (A misbehaving client
* could easily page fault using this call).
*
******************************************************************)
function GET_Short : Short;
begin
GET_Short := (Short(current_frame^[ frame_cursor ]) shl 8) or
Short(current_frame^[frame_cursor+1]);
inc( frame_cursor, 2 );
end;
(*******************************************************************
*
* Function : GET_UShort
*
* Description : Extracts an unsigned short from the frame
*
* Input : None
*
* Output : Extracted ushort.
*
* NOTES : We consider that the programmer is intelligent enough
* not to try to get a byte that is out of the frame. Hence,
* we provide no bounds check here. (A misbehaving client
* could easily page fault using this call).
*
******************************************************************)
function GET_UShort : UShort;
begin
GET_UShort := (UShort(current_frame^[ frame_cursor ]) shl 8) or
UShort(current_frame^[frame_cursor+1]);
inc( frame_cursor, 2 );
end;
(*******************************************************************
*
* Function : GET_Long
*
* Description : Extracts a long from the frame
*
* Input : None
*
* Output : Extracted long.
*
* NOTES : We consider that the programmer is intelligent enough
* not to try to get a byte that is out of the frame. Hence,
* we provide no bounds check here. (A misbehaving client
* could easily page fault using this call).
*
******************************************************************)
function GET_Long : Long;
begin
GET_Long := (Long(current_frame^[ frame_cursor ]) shl 24) or
(Long(current_frame^[frame_cursor+1]) shl 16) or
(Long(current_frame^[frame_cursor+2]) shl 8 ) or
(Long(current_frame^[frame_cursor+3]) );
inc( frame_cursor, 4 );
end;
(*******************************************************************
*
* Function : GET_ULong
*
* Description : Extracts an unsigned long from the frame
*
* Input : None
*
* Output : Extracted ulong.
*
* NOTES : We consider that the programmer is intelligent enough
* not to try to get a byte that is out of the frame. Hence,
* we provide no bounds check here. (A misbehaving client
* could easily page fault using this call).
*
******************************************************************)
function GET_ULong : ULong;
begin
GET_ULong := (ULong(current_frame^[ frame_cursor ]) shl 24) or
(ULong(current_frame^[frame_cursor+1]) shl 16) or
(ULong(current_frame^[frame_cursor+2]) shl 8 ) or
(ULong(current_frame^[frame_cursor+3]) );
inc( frame_cursor, 4 );
end;
(*******************************************************************
*
* Function : GET_Tag4
*
* Description : Extracts a Tag from the frame
*
* Input : None
*
* Output : Extracted 4 byte Tag.
*
* NOTES : We consider that the programmer is intelligent enough
* not to try to get a byte that is out of the frame. Hence,
* we provide no bounds check here. (A misbehaving client
* could easily page fault using this call).
*
******************************************************************)
function GET_Tag4 : ULong;
var
C : array[0..3] of Byte;
begin
move ( current_frame^[frame_cursor], c, 4 );
inc( frame_cursor, 4 );
GET_Tag4 := ULong(C);
end;
end.

1391
pascal/lib/ttgload.pas Normal file
View File

File diff suppressed because it is too large Load Diff

4797
pascal/lib/ttinterp.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1496
pascal/lib/ttload.pas Normal file
View File

File diff suppressed because it is too large Load Diff

282
pascal/lib/ttmemory.pas Normal file
View File

@@ -0,0 +1,282 @@
(*******************************************************************
*
* TTMemory.Pas 2.1
*
* Memory management component (specification)
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
* Differences between 2.1 and 2.0 :
*
* - Added a memory mutex to make the component thread-safe
*
* Differences between 2.0 and 1.1 :
*
* - The growing heap was completely removed in version 2.0
*
* - The support for small mini-heaps may be re-introduced later
* to allow the storage of several consecutive arrays in one
* single block.
*
* IMPORTANT NOTICE :
*
* The Alloc and Free functions mimic their C equivalent,
* however, some points must be noticed :
*
* - both functions return a boolean. As usual, True indicates
* success, while False indicates failure.
*
* - the Alloc function puts a small header on front of each
* allocated block. The header contains a magic cookie and
* the size of the allocated block. This allows calls to
* Free without passing a block size as an argument, and thus
* reduces the risks of memory leaks.
*
* - it is possible to call Free with a nil pointer, in which
* case nothing happens, and the result is set to True (success)
*
* The pointer is set to nil after a call to Free in all cases.
*
* This is done to clear the destructors code, allowing
*
* if (pointer) then
* begin
* Free(pointer);
* pointer := nil;
* end;
*
* to be replaced by a single line :
*
* Free(pointer);
*
*
******************************************************************)
unit TTMemory;
interface
uses TTTypes;
{$I TTCONFIG.INC}
type
TMarkRecord = record
Magic : longint;
Top : integer;
end;
const
Font_Pool_Allocated : boolean = False;
function Alloc( var P; size : Longint ) : TError;
(* Allocates a new memory block in the current heap of 'size' bytes *)
(* - returns failure if no memory is left in the heap *)
procedure Free ( var P );
(* Releases a block previously allocated through 'Alloc' *)
(* - returns True (success) of P is nil before the call *)
(* - sets P to nil before exit *)
function TTMemory_Init : TError;
procedure TTMemory_Done;
implementation
uses TTError;
type
TByte = array[0..0] of Byte;
PByte = ^TByte;
PBlock_Header = ^TBlock_Header;
TBlock_Header = record
magic : Longint; (* magic cookie *)
size : Longint; (* allocated size, including header *)
end;
TBlock_Headers = array[0..1] of TBlock_Header;
PBlock_Headers = ^TBlock_Headers;
(* Note that the Turbo-Pascal GetMem/FreeMem functions use no block *)
(* headers. That's why a byte size is needed for FreeMem. Thus, we *)
(* do not waste space here compared to a C malloc implementation *)
const
Mark_Magic = $BABE0007;
(* This is the magic cookie used to recognize valide allocated blocks *)
Header_Size = sizeof(TBlock_Header);
(************************************************************************)
(* *)
(* MyHeapErr : *)
(* *)
(* By default, a call to GetMem with insufficient memory left will *)
(* generate a runtime error. We define here a function that is used *)
(* to allow GetMem to return nil in such cases. *)
(* *)
(************************************************************************)
function MyHeapErr( Size: Integer ): Integer; far;
begin
MyHeapErr := 1;
end;
(*******************************************************************
*
* Function : Alloc
*
* Description : allocate a new block in the current heap
*
* Notes : If you want to replace this function with
* your own, please be sure to respect these
* simple rules :
*
* - P must be set to nil in case of failure
*
* - The allocated block must be zeroed !
*
*****************************************************************)
function Alloc( var P; size : Longint ) : TError;
var
OldHeapError : Pointer;
L : Longint;
P2 : Pointer;
begin
{$IFNDEF DELPHI32}
OldHeapError := HeapError;
HeapError := @MyHeapErr;
{$ENDIF}
L := ( size + Header_Size + 3 ) and -4;
{$IFDEF MSDOS}
if L shr 16 <> 0 then
begin
Writeln('Sorry, but this font is too large to be handled by a 16-bit program' );
Alloc := Failure;
end;
{$ENDIF}
GetMem( Pointer(P), L );
{$IFNDEF DELPHI32}
HeapError := OldHeapError;
{$ENDIF}
if Pointer(P) <> nil then
begin
PBlock_Headers(P)^[0].magic := Mark_Magic;
PBlock_Headers(P)^[0].size := L;
P2 := Pointer( @(PBlock_Headers(P)^[1]) );
{$IFDEF MSDOS}
if (ofs(P2^) <> ofs(Pointer(P)^)+Header_Size) or
(seg(P2^) <> seg(Pointer(P)^)) then
begin
Writeln('AAARGH !!: Sorry, but I have problems with 64 Kb segments');
halt(1);
end;
{$ENDIF}
Pointer(P) := P2;
fillchar( P2^, size, 0 );
(* zero block *)
Alloc := Success;
end
else
Alloc := Failure;
end;
(*******************************************************************
*
* Function : Free
*
* Description : frees a block that was previsouly allocated
* by the Alloc function
*
* Notes : Doesn't need any size parameter.
*
* If you want to replace this function with your own, please
* be sure to respect these two rules :
*
* - the argument pointer can be nil, in which case the function
* should return immediately, with a success report.
*
* - the pointer P should be set to nil when exiting the
* function, except in case of failure.
*
*****************************************************************)
procedure Free( var P );
var
head : PBlock_Header;
i : Integer;
size : Longint;
begin
if Pointer(P) = nil then exit;
i := -1;
head := @(PBlock_Headers(P)^[i]);
(* A hack to get the header in PB, as the line *)
(* @(PBlock_Headers(P)^[-1] would give a 'constant error' *)
(* at compile time. I'm unsure this works correctly in BP *)
if head^.magic <> Mark_Magic then
begin
(* PANIC : An invalid Free call *)
Writeln('Invalid Free call');
halt(1);
end;
size := head^.size;
head^.magic := 0; (* cleans the header *)
head^.size := 0;
FreeMem( head, size );
Pointer(P) := nil;
end;
(*******************************************************************
*
* Function : TTMemory_Init
*
* Description : Initializes the Memory component
*
*****************************************************************)
function TTMemory_Init : TError;
begin
(* nothing to be done *)
TTMemory_Init := Success;
end;
(*******************************************************************
*
* Function : TTMemory_Done
*
* Description : Finalize the memory component
*
*****************************************************************)
procedure TTMemory_Done;
begin
(* nothing to be done *)
end;
end.

1945
pascal/lib/ttobjs.pas Normal file
View File

File diff suppressed because it is too large Load Diff

3445
pascal/lib/ttraster.pas Normal file
View File

File diff suppressed because it is too large Load Diff

247
pascal/lib/tttables.pas Normal file
View File

@@ -0,0 +1,247 @@
(*******************************************************************
*
* TTTables.Pas 1.2
*
* TrueType Tables declarations
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
*
* Difference between 1.1 and 1.2 :
*
* - TTTables now only contains the declarations of the
* TrueType tables.
*
* - Instance, Resident and Execution context declarations
* were moved to TTObjs
*
* - Tables loaders were moved to the new TTLoad component
*
******************************************************************)
Unit TTTables;
interface
uses FreeType, TTTypes;
(***************************************************************************)
(* *)
(* TrueType Table Types *)
(* *)
(***************************************************************************)
type
(* TrueType collection header *)
PTTCHeader = ^TTTCHeader;
TTTCHeader = record
Tag : Long;
version : TT_Fixed;
DirCount : ULong;
TableDirectory : PStorage;
end;
(* TrueType Table Directory type *)
PTableDir = ^TTableDir;
TTableDir = Record
version : TT_Fixed; (* should be $10000 *)
numTables : UShort; (* Tables number *)
searchRange, (* These parameters are only used *)
entrySelector, (* for a dichotomy search in the *)
rangeShift : UShort; (* directory. We ignore them *)
end;
(* The 'TableDir' is followed by 'numTables' TableDirEntries *)
TTableDirEntry = Record
Tag : Long; (* table type *)
CheckSum : Long; (* table Checksum *)
Offset : Long; (* Table file offset *)
Length : Long; (* Table length *)
end;
TTableDirEntries = array[0..100] of TTableDirEntry;
PTableDirEntries = ^TTableDirEntries;
(* 'cmap' tables *)
TCMapDir = record
tableVersionNumber : UShort;
numCMaps : UShort;
end;
TCMapDirEntry = record
platformID : UShort;
platformEncodingID : UShort;
offset : Long;
end;
TCMapDirEntries = array[0..10] of TCMapDirEntry;
PCMapDirEntries = ^TCMapDirEntries;
(* table "maxp" of Maximum Profiles' *)
TMaxProfile = Record
Version : TT_Fixed;
numGlyphs,
maxPoints,
maxContours,
maxCompositePoints,
maxCompositeContours,
maxZones,
maxTwilightPoints,
maxStorage,
maxFunctionDefs,
maxInstructionDefs,
maxStackElements,
maxSizeOfInstructions,
maxComponentElements,
maxComponentDepth : UShort;
end;
(* table "gasp" *)
const
Gasp_GridFit = 1;
Gasp_DoGray = 2;
type
TGaspRange = record
maxPPEM : UShort;
gaspFlag : UShort;
end;
TGaspRanges = array[0..9] of TGaspRange;
PGaspRanges = ^TGaspRanges;
TGasp = record
version : UShort;
numRanges : UShort;
gaspRanges : PGaspRanges;
end;
(* table "HMTX" *)
TLongMetrics = record
advance : UShort;
bearing : Short;
end;
TTableLongMetrics = array[0..255] of TLongMetrics;
PTableLongMetrics = ^TTableLongMetrics;
TShortMetrics = Short;
TTableShortMetrics = array[0..255] of TShortMetrics;
PTableShortMetrics = ^TTableShortMetrics;
{
(* table "OS/2" *)
TOS2_Table = record
version : UShort; (* $0001 *)
xAvgCharWidth : Short;
usWeightClass : UShort;
usWidthClass : UShort;
fsType : Short;
ySubscriptXSize : Short;
ySubscriptYSize : Short;
ySubScriptXOffset : Short;
ySubscriptYOffset : Short;
ySuperscriptXSize : Short;
ySuperscriptYSize : Short;
ySuperscriptXOffset : Short;
ySuperscriptYOffset : Short;
yStrikeoutSize : Short;
yStrikeoutPosition : Short;
sFamilyClass : Short;
panose : array[0..9] of Byte;
ulUnicodeRange1 : ULong; (* bits 0-31 *)
ulUnicodeRange2 : ULong; (* bits 32-63 *)
ulUnicodeRange3 : ULong; (* bits 64-95 *)
ulUnicodeRange4 : ULong; (* bits 96-127 *)
achVendID : array[0..3] of Byte;
fsSelection : UShort;
usFirstCharIndex : UShort;
usLastCharIndex : UShort;
sTypoAscender : UShort;
sTypoDescender : UShort;
sTypoLineGap : UShort;
usWinAscent : UShort;
usWinDescent : UShort;
(* only version 1 tables *)
ulCodePageRange1 : ULong;
ulCodePageRange2 : ULong;
end;
(* table "post" *)
TPostscript = record
FormatType : TT_Fixed;
italicAngle : TT_Fixed;
underlinePosition : Short;
underlineThickness : Short;
isFixedPitch : ULong;
minMemType42 : ULong;
maxMemType42 : ULong;
minMemType1 : ULong;
maxMemType1 : ULong;
end;
}
(* table "name" *)
(* table "name" *)
TName_Record = record
platformID : UShort;
encodingID : UShort;
languageID : UShort;
nameID : UShort;
length : UShort;
offset : UShort;
end;
PName_Record = ^TName_Record;
TName_Records = array[0..0] of TName_Record;
PName_Records = ^TName_Records;
PName_Table = ^TName_Table;
TName_Table = record
format : UShort;
numNameRecords : UShort;
storageOffset : UShort;
names : PName_Records;
storage : PByte;
end;
PHdmx_Record = ^THdmx_Record;
THdmx_Record = record
ppem : Byte;
max_width : Byte;
widths : PByte;
end;
THdmx_Records = array[0..19] of THdmx_Record;
PHdmx_Records = ^THdmx_Records;
THdmx = record
version : UShort;
num_records : Short;
records : PHdmx_Records;
end;
implementation
end.

102
pascal/lib/tttypes.pas Normal file
View File

@@ -0,0 +1,102 @@
(*******************************************************************
*
* TTTypes.pas 1.0
*
* Global internal types definitions
*
* Copyright 1996, 1997 by
* David Turner, Robert Wilhelm, and Werner Lemberg.
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
******************************************************************)
unit TTTypes;
interface
uses FreeType;
type
(*********************** SIMPLE PRIMITIVE TYPES *******************)
(* BYTE is already defined in Pascal *)
(* They are equivalent to C unsigned chars *)
UShort = Word; (* unsigned short integer, must be on 16 bits *)
Short = Integer; (* signed short integer, must be on 16 bits *)
Long = Longint;
ULong = LongInt; (* unsigned long integer, must be on 32 bits *)
(* NOTE : There is no 'LongWord' in Pascal, *)
(* but the unsigned ops are all in *)
(* the inline assembly routines *)
{$IFDEF USE32}
Int = LongInt; (* the 'int' type is used for loop counters and *)
{$ELSE} (* indexes.. Their size must be the one a given *)
Int = Integer; (* system handles most easily ( 16 bits on Turbo *)
{$ENDIF} (* and 32 on Virtual Pascals ) *)
TByteArray = array[0..1000] of Byte;
PByte = ^TByteArray;
TShortArray = array[0..1000] of Short;
PShort = ^TShortArray;
TUShortArray = array[0..1000] of UShort;
PUShort = ^TUShortArray;
TStorage = array[0..16000] of Long;
PStorage = ^TStorage;
PLong = PStorage;
PULong = PStorage;
TError = boolean;
(***************** FreeType Internal Types *****************************)
TCoordinates = array[0..1023] of TT_F26Dot6;
PCoordinates = ^TCoordinates;
PTouchTable = PByte;
TVecRecord = record
n : Int; (* number of points *)
org_x : PCoordinates; (* original coordinates arrays *)
org_y : PCoordinates;
cur_x : PCoordinates; (* current coordinates arrays *)
cur_y : PCoordinates;
touch : PTouchTable; (* touch flags array *)
end;
(* This type is used to describe each point zone in the interpreter *)
const
TT_Round_Off = 5;
TT_Round_To_Half_Grid = 0;
TT_Round_To_Grid = 1;
TT_Round_To_Double_Grid = 2;
TT_Round_Up_To_Grid = 4;
TT_Round_Down_To_Grid = 3;
TT_Round_Super = 6;
TT_ROund_Super_45 = 7;
Success = False;
Failure = True;
TT_Flag_Touched_X = $02; (* X touched flag *)
TT_Flag_Touched_Y = $04; (* Y touched flag *)
TT_Flag_Touched_Both = TT_Flag_Touched_X or TT_FLag_Touched_Y;
TT_Flag_On_Curve = $01; (* Point is On curve *)
implementation
end.

248
pascal/test/codetv.pas Normal file
View File

@@ -0,0 +1,248 @@
{****************************************************************************}
{* *}
{* CodeView.PAS *}
{* *}
{* This unit implements a simple TrueType bytecode viewer for the *}
{* FREETYPE project debugger. *}
{* *}
{****************************************************************************}
Unit CodeTV;
interface
uses Objects, Views, Drivers, TTTypes, TTDebug;
{$I DEBUGGER.INC}
type
{ TCodeViewer }
{ This TView is a simple code list viewer ( IP + focused + breaks ) }
PCodeViewer = ^TCodeViewer;
TCodeViewer = object( TListViewer )
constructor Init( var Bounds : TRect;
ARange : PRangeRec );
procedure Draw; virtual;
procedure HandleEvent( var Event : TEvent ); virtual;
procedure Change_Range( ARange : PRangeRec );
procedure Change_Focus( ALine : integer );
procedure Get_Cursor_Addr( P : PLong );
private
CodeRange : PRangeRec;
IP : Int;
end;
{ TCodeWindow }
PCodeWindow = ^TCodeWindow;
TCodeWindow = object( TWindow )
CodeView : PCodeViewer;
constructor Init( var Bounds : TRect;
ARange : PRangeRec );
end;
implementation
{ TCodeViewer }
constructor TCodeViewer.Init;
begin
inherited Init( Bounds, 1, nil, nil );
GrowMode := gfGrowHiX or gfGrowHiY;
DragMode := dmDragGrow or dmLimitLoX or dmLimitLoY;
EventMask := EventMask or evWave;
IP := 0;
Change_Range( ARange );
end;
procedure TCodeViewer.Change_Range;
begin
codeRange := ARange;
if codeRange <> nil then
SetRange( codeRange^.NLines )
else
SetRange( 0 );
end;
procedure TCodeViewer.Change_Focus;
begin
if ALine < 0 then
begin
IP := -1;
DrawView;
exit;
end;
if ALine >= TopItem + Size.Y then TopItem := ALine;
if codeRange <> nil then
begin
FocusItem( ALine );
IP := codeRange^.Disassembled^[ALine];
end;
DrawView;
end;
procedure TCodeViewer.Get_Cursor_Addr( P : PLong );
begin
with codeRange^ do
begin
if (Focused < 0) or (Focused >= NLines) then
P^[0] := -1
else
P^[0] := disassembled^[Focused];
end;
end;
procedure TCodeViewer.HandleEvent( var Event : TEvent );
var
Limits : TRect;
Mini, Maxi : Objects.TPoint;
begin
inherited HandleEvent(Event);
case Event.What of
evCommand : case Event.Command of
cmChangeRange : Change_Range( Event.InfoPtr );
cmQueryCursorAddr : Get_Cursor_Addr( Event.InfoPtr );
cmResize: begin
Owner^.GetExtent(Limits);
SizeLimits( Mini, Maxi );
DragView(Event, DragMode, Limits, Mini, Maxi );
ClearEvent(Event);
end;
end;
evWave : case Event.Command of
cmReFocus : Change_Focus( Event.InfoInt );
end;
end;
end;
procedure TCodeViewer.Draw;
const
Colors : array[0..3] of byte
= ($1E,$40,$0E,$30);
Prefix : array[1..3] of Char
= ( 'f', 'c', 'g' );
var
I, J, Item : Int;
B : TDrawBuffer;
S : String;
Indent : Int;
Ligne : Int;
Color : word;
On_BP : boolean;
BP : PBreakPoint;
begin
{
Colors[0] := GetColor(1); (* Normal line *)
Colors[1] := GetColor(2); (* Normal breakpoint *)
Colors[2] := GetColor(3); (* Focused line *)
Colors[3] := GetColor(4); (* Focused breakpoint *)
}
if HScrollBar <> nil then Indent := HScrollBar^.Value
else Indent := 0;
with CodeRange^ do
begin
BP := Breaks;
if (BP <> nil) and (NLines > TopItem) then
while (BP <> nil) and (BP^.Address < Disassembled^[TopItem]) do
BP := BP^.Next;
for I := 0 to Self.Size.Y-1 do
begin
Item := TopItem + I;
Color := 0;
if Item < NLines then
begin
Ligne := Disassembled^[Item];
if (BP <> nil) and (BP^.Address = Ligne) then
begin
Color := 1;
Repeat
BP := BP^.Next
until (BP = nil) or (BP^.Address > Ligne);
end;
if (Range > 0) and
( Focused = Item ) then
Color := Color or 2;
S := ' ' + Cur_U_Line( Code, Ligne );
S[2] := Prefix[index];
S := copy( S, 1 + Indent, Self.Size.X );
if Ligne = IP then
begin
S[1] := '=';
S[7] := '>';
end
end
else
begin
S := '';
end;
Color := Colors[Color];
MoveChar( B, ' ', Color, Self.Size.X );
MoveStr( B, S, Color );
WriteLine( 0, I, Self.Size.X, 1, B );
end;
end;
end;
{ TCodeWindow }
constructor TCodeWindow.Init;
begin
inherited Init( Bounds,'Code',wnNoNumber );
GetExtent( Bounds );
Bounds.Grow(-1,-1);
New( CodeView, Init( Bounds, ARange ) );
Insert( CodeView );
end;
end.

84
pascal/test/common.pas Normal file
View File

@@ -0,0 +1,84 @@
Unit Common;
interface
const
Max_Arguments = 1024;
var
num_arguments : integer;
(* the number of arguments contained in the 'arguments' array *)
arguments : array[0..Max_Arguments-1] of ^string;
(* This array will hold all arguments after wildcard expansion *)
(* note that it will not contain the original arguments that *)
(* were before 'first_argument' of Expand_Wildcards *)
procedure Expand_WildCards( first_argument : integer;
default_extension : string );
(* expand all wildcards into filenames *)
implementation
uses Dos;
procedure Split( Original : String;
var Base : String;
var Name : String );
var
n : integer;
begin
n := length(Original);
while ( n > 0 ) do
if ( Original[n] = '\' ) or
( Original[n] = '/' ) then
begin
Base := Copy( Original, 1, n-1 );
Name := Copy( Original, n+1, length(Original) );
exit;
end
else
dec(n);
Base := '';
Name := Original;
end;
procedure Expand_WildCards( first_argument : integer;
default_extension : string );
var
i, n : integer;
base, name : string;
SRec : SearchRec;
begin
num_arguments := 0;
i := first_argument;
while ( i <= ParamCount ) do
begin
Split( ParamStr(i), base, name );
if base <> '' then
base := base + '\';
FindFirst( base+name, Archive+ReadOnly+Hidden, SRec );
if DosError <> 0 then
FindFirst( base+name+default_extension, AnyFile, SRec );
while (DosError = 0) and (num_arguments < Max_Arguments) do
begin
GetMem( arguments[num_arguments], length(base)+length(SRec.Name)+1 );
arguments[num_arguments]^ := base + SRec.Name;
inc( num_arguments );
FindNext( SRec );
end;
{$IFDEF OS2}
FindClose( SRec );
{$ENDIF}
inc( i );
end;
end;
end.

42
pascal/test/debugger.inc Normal file
View File

@@ -0,0 +1,42 @@
{ DEBUGGER.INC : Constantes des commandes du debugger FREETYPE }
const
evWave = $200; { Broadcast messages }
cmNewWin = 200;
cmFileOpen = 201;
cmNewExecution = 300;
cmRefocus = 301;
cmChangeRange = 302;
cmQueryCursorAddr = 303;
cmRun = 400;
kb_val_Run = kbCtrlF9;
kb_str_Run = 'Ctrl-F9';
cmGotoCursor = 401;
kb_val_GotoCursor = kbF4;
kb_str_GotoCursor = 'F4';
cmTraceInto = 402;
kb_val_TraceInto = kbF7;
kb_str_TraceInto = 'F7';
cmStepOver = 403;
kb_val_StepOver = kbF8;
kb_str_StepOver = 'F8';
cmUntilReturn = 404;
kb_val_UntilReturn = kbAltF8;
kb_str_UntilReturn = 'Alt-F8';
cmToggleBreak = 500;
kb_val_ToggleBreak = kbCtrlF8;
cmClearBreaks = 501;
cmViewGlyph = 600;
kb_val_ViewGlyph = kbF9;
kb_str_ViewGlyph = 'F9';

924
pascal/test/debugger.pas Normal file
View File

@@ -0,0 +1,924 @@
program Debugger;
uses
{$IFDEF OS2}
Use32,
{$ENDIF}
(* Turbo Vision units *)
Drivers,
Objects,
Views,
Menus,
App,
MsgBox,
Crt,
(* FreeType units *)
FreeType,
TTInterp,
TTTypes,
TTMemory,
TTError,
TTTables,
TTObjs,
TTFile,
TTCalc,
TTDebug,
TTRaster,
(* graphics system units *)
GDriver,
GMain,
GEvents,
(* Debugger's Turbo Vision enhancements *)
CodeTv,
StackTv,
StateTv,
ZoneTv;
{$I DEBUGGER.INC}
(* define this variable if you want to debug the CVT rather than a *)
(* glyph's instruction set.. *)
{ $DEFINE DEBUG_CVT}
const
Precis = 64;
Screen_Width = 640;
Screen_Height = 480;
Screen_Cols = Screen_Width div 8;
Screen_Size = Screen_Cols * Screen_Height;
Grid_Width = Screen_Width div 16;
Grid_Height = Screen_Height div 16;
Grid_Cols = Grid_Width div 8;
Grid_Size = Grid_Cols * Grid_Height;
Screen_Center_X = Screen_Width div 2;
Screen_Center_Y = Screen_Height div 2;
Grid_Center_X = Grid_Width div 2;
Grid_Center_Y = Grid_Height div 2;
Profile_Buff_Size = 64000;
type
TDebug_Mode = ( debug_code, view_glyph );
TMyApp = object( TApplication )
constructor Init;
procedure NewWindow; virtual;
procedure InitMenuBar; virtual;
procedure HandleEvent( var Event : TEvent ); virtual;
procedure Single_Step;
procedure Execute_Loop;
procedure New_Execution;
procedure ReFocus;
end;
TEtat = ( etat_Termine, etat_Arret, etat_Execution );
TVolatileBreakPoint = record
range : Int;
address : Int;
end;
var
CW : PCodeWindow;
SW : PStackWindow;
GW : PStateWindow;
ZW : PZoneWindow;
Code_Range : array[1..3] of PCodeRange;
Gen_Range : array[1..3] of TRangeRec;
old_Range : Int;
stream : TT_Stream;
the_face : TT_Face;
the_glyph : TT_Glyph;
the_instance : TT_Instance;
face : PFace;
glyph : PGlyph;
glyph2 : PGlyph;
instance : PInstance;
exec : PExec_Context;
error : TT_Error;
Etat : TEtat;
Volatiles : PBreakPoint;
xCoord : TT_PCoordinates;
yCoord : TT_PCoordinates;
Flag : TT_PTouchTable;
Bitmap_small : TT_Raster_Map;
Bitmap_big : TT_Raster_Map;
display_outline : boolean;
hint_glyph : boolean;
debug_mode : TDebug_Mode;
MyApp : TMyApp;
Range : Int;
P : PByteArray;
FileName : String;
Font_Buffer : PStorage;
Out_File : Text;
T, I : int;
glyph_number : Int;
point_size : Int;
procedure Initialize;
var
i : int;
begin
for i := 1 to 3 do Code_Range[i] := Get_CodeRange(exec,i);
for i := 1 to 3 do Generate_Range( Code_Range[i], i, Gen_Range[i] );
Volatiles := nil;
display_outline := true;
Debug_Mode := debug_code;
end;
(*******************************************************************
*
* Function : InitRows
*
* Description : Allocates the target bitmaps
*
*****************************************************************)
Procedure Init_Engine;
var
P: Pointer;
begin
(* The big bitmap will contain the grid, the glyph contours and *)
(* the magnified bitmap *)
Bitmap_big.rows := Screen_Height;
Bitmap_big.cols := Screen_Cols;
Bitmap_big.width := Screen_Width;
Bitmap_big.flow := TT_Flow_Up;
Bitmap_big.size := Screen_Size;
GetMem( Bitmap_big.buffer, Bitmap_big.size );
if Bitmap_big.buffer = NIL then
begin
Writeln('ERREUR:InitRows:Not enough memory to allocate big BitMap');
halt(1);
end;
(* The small bitmap contains the rendered glyph, and is then later *)
(* magnified into the big bitmap *)
Bitmap_small.rows := Grid_Height;
Bitmap_small.cols := Grid_Cols;
Bitmap_small.width := Grid_Width;
Bitmap_small.flow := TT_Flow_Up;
Bitmap_small.size := Grid_Size;
GetMem( Bitmap_small.buffer, Bitmap_small.size );
if Bitmap_small.buffer = NIL then
begin
Writeln('ERREUR:InitRows:Not enough memory to allocate big BitMap');
halt(1);
end;
FillChar( Bitmap_big.Buffer^, Bitmap_big.Size, 0 );
FillChar( Bitmap_small.Buffer^, Bitmap_small.size, 0 );
end;
(*******************************************************************
*
* Function : ClearData
*
* Description : Clears the bitmaps
*
*****************************************************************)
Procedure ClearData;
var i: integer;
begin
FillChar( Bitmap_big. Buffer^, Bitmap_big. Size, 0 );
FillChar( Bitmap_small.Buffer^, Bitmap_small.size, 0 );
end;
function Render_Magnified : boolean;
label
Exit_1;
type
TBlock = array[0..7] of Byte;
PBlock = ^TBlock;
const
{
Grid_Empty : TBlock
= ( $10, $10, $10, $FF, $10, $10, $10, $10 );
}
Grid_Pixel2 : TBlock
= ( $FE, $FE, $FE, $FE, $FE, $FE, $FE, $00 );
Pixel_Center_X = 3;
Pixel_Center_Y = 3;
Grid_Empty : TBlock
= ( $00, $00, $00, $10, $00, $00, $00, $00 );
Grid_Pixel1 : TBlock
= ( $00, $00, $38, $38, $38, $00, $00, $00 );
Big_Center_X = Grid_Center_X*16 + Pixel_Center_X;
Big_Center_Y = Grid_Center_Y*16 + Pixel_Center_Y;
var
r, w, w2, u, v, b, c : integer;
x, y : Long;
block : PBlock;
G : TT_Outline;
pixel,
empty : PBlock;
numPoints : integer;
begin
Render_Magnified := False;
ClearData;
numpoints := exec^.pts.n_points - 2; (* Remove phantom points *)
for r := 0 to numPoints-1 do with exec^.pts do
begin
glyph2^.outline.points^[r].x := exec^.pts.cur^[r].x+64;
glyph2^.outline.points^[r].y := exec^.pts.cur^[r].y+64;
end;
(* We begin rendering the glyph within the small bitmap *)
G.n_contours := glyph^.outline.n_contours;
G.conEnds := glyph^.outline.conEnds;
G.Points := glyph^.outline.points;
G.points := glyph2^.outline.points;
G.Flags := glyph^.outline.flags;
G.second_pass := True;
G.high_precision := True;
G.dropout_mode := 2;
if Render_Glyph ( G, Bitmap_small ) then goto Exit_1;
(* Then, we render the glyph outline in the bit bitmap *)
for r := 0 to numPoints-1 do
begin
x := exec^.pts.cur^[r].x;
y := exec^.pts.cur^[r].y;
x := (x - Precis*Grid_Center_X)*16 + Big_Center_X*Precis;
y := (y - Precis*Grid_Center_Y)*16 + Big_Center_Y*Precis;
glyph2^.outline.points^[r].x := x + 8*64;
glyph2^.outline.points^[r].y := y + 8*64;
end;
(* first compute the magnified coordinates *)
G.n_contours := glyph^.outline.n_contours;
G.conEnds := glyph^.outline.conEnds;
G.Points := glyph^.outline.points;
G.points := glyph2^.outline.points;
G.Flags := glyph^.outline.flags;
G.second_pass := True;
G.high_precision := True;
G.dropout_mode := 2;
if display_outline then
if Render_Glyph ( G, Bitmap_big ) then goto Exit_1;
(* Now, magnify the small bitmap, XORing it to the big bitmap *)
r := 0;
w := 0;
b := 0;
empty := @Grid_Empty;
if display_outline then pixel := @Grid_Pixel1
else pixel := @Grid_Pixel2;
for y := 0 to Grid_Height-1 do
begin
for x := 0 to Grid_Width-1 do
begin
w2 := w;
b := b shr 1;
if b = 0 then
begin
c := PByte(Bitmap_small.Buffer)^[r];
b := $80;
inc( r );
end;
if c and b <> 0 then block := pixel
else block := empty;
for v := 0 to 7 do
begin
PByte(Bitmap_Big.Buffer)^[w2] := PByte(Bitmap_Big.Buffer)^[w2]
xor block^[v];
inc( w2, Bitmap_Big.cols );
end;
inc( w, 2 );
end;
inc( w, 15*Screen_Cols );
end;
(* Display the resulting big bitmap *)
Display_BitMap_On_Screen( Bitmap_big.Buffer^, 450, 80 );
Exit_1:
(* Clear the bitmaps *)
Render_Magnified := True;
end;
function Render_Simple : boolean;
label
Exit_1;
var
r, w, w2, u, v, b, c : integer;
x, y : Long;
G : TT_Outline;
numPoints : integer;
begin
Render_Simple := False;
numpoints := exec^.pts.n_points - 2; (* Remove phantom points *)
for r := 0 to numPoints-1 do with exec^.pts do
begin
glyph2^.outline.points^[r].x := exec^.pts.cur^[r].x + 32;
glyph2^.outline.points^[r].y := exec^.pts.cur^[r].y + 32;
end;
(* We begin rendering the glyph within the small bitmap *)
G.n_contours := glyph^.outline.n_contours;
G.conEnds := glyph^.outline.conEnds;
G.Points := glyph^.outline.points;
G.points := glyph2^.outline.points;
G.Flags := glyph^.outline.flags;
G.second_pass := True;
G.high_precision := True;
G.dropout_mode := 2;
if display_outline then
if Render_Glyph ( G, Bitmap_big ) then goto Exit_1;
(* Display the resulting big bitmap *)
Display_BitMap_On_Screen( Bitmap_big.Buffer^, 450, 80 );
Exit_1:
(* Clear the bitmaps *)
ClearData;
Render_Simple := True;
end;
procedure Exit_Viewer;
begin
Restore_Screen;
debug_mode := debug_code;
MyApp.SetScreenMode( smCo80 + smFont8x8 );
MyApp.Show;
MyApp.ReDraw;
end;
procedure Enter_Viewer;
begin
Set_Graph_Screen( Graphics_Mode_Mono );
if not Render_Magnified then
Exit_Viewer
else
debug_mode := view_glyph;
end;
procedure TMyApp.Execute_Loop;
var
Out : Boolean;
B : PBreakPoint;
Event : TEvent;
begin
Out := False;
etat := etat_Execution;
repeat
Single_Step;
B := Find_BreakPoint( Volatiles, exec^.curRange, exec^.IP );
if B <> nil then
begin
Clear_Break( Volatiles, B );
Out := True;
end;
if etat = etat_Execution then
begin
B := Find_BreakPoint( Gen_Range[exec^.curRange].Breaks,
exec^.curRange,
exec^.IP );
if B <> nil then
begin
Out := True;
Etat := etat_Arret;
end;
end
else
Out := True;
until Out;
end;
procedure TMyApp.New_Execution;
var
Event : TEvent;
begin
Event.What := evWave;
Event.Command := cmNewExecution;
HandleEvent( Event );
end;
procedure TMyApp.Single_Step;
var
tempStr : string[6];
begin
if Run_Ins( exec ) then
begin
etat := etat_Termine;
str( exec^.error, tempStr );
MessageBox( 'Error : '+tempStr, nil, mfError+mfOkButton );
exit;
end;
if exec^.IP >= exec^.codeSize then
begin
if (exec^.curRange <> TT_CodeRange_CVT) or
Goto_CodeRange( exec, TT_CodeRange_Glyph, 0 ) then
begin
etat := etat_Termine;
MessageBox( 'Completed', nil, mfInformation+mfOkButton );
exit;
end;
end
end;
procedure TMyApp.ReFocus;
var
Event : TEvent;
begin
Event.What := evCommand;
if Old_Range <> exec^.curRange then
begin
Old_Range := exec^.curRange;
Event.Command := cmChangeRange;
Event.InfoPtr := @Gen_Range[Old_Range];
CW^.HandleEvent( Event );
end;
Event.What := evWave;
Event.Command := cmRefocus;
if etat <> etat_Termine then
Event.InfoInt := Get_Dis_Line( Gen_Range[Old_Range], exec^.IP )
else
Event.InfoInt := -1;
HandleEvent( Event );
end;
procedure TMyApp.NewWindow;
var
R : TRect;
RR : TRangeRec;
begin
Desktop^.GetExtent(R);
R.B.X := 32;
Old_Range := exec^.curRange;
New( CW, Init( R, @Gen_Range[Old_Range] ) );
Desktop^.Insert(CW);
Desktop^.GetExtent(R);
R.A.X := 32;
R.B.X := 50;
R.B.Y := R.B.Y div 2;
New( SW, Init( R, exec ) );
Desktop^.Insert(SW);
Desktop^.GetExtent(R);
R.A.X := 50;
R.B.Y := R.B.Y div 2;
New( GW, Init( R, exec ) );
Desktop^.Insert(GW);
Desktop^.GetExtent(R);
R.A.X := 32;
R.A.Y := R.B.Y div 2;
{$IFDEF DEBUG_CVT}
New( ZW, Init( R, @exec^.twilight ) );
{$ELSE}
New( ZW, Init( R, @exec^.pts ) );
{$ENDIF}
Desktop^.Insert(ZW);
etat := etat_Arret;
end;
procedure TMyApp.InitMenuBar;
var
R : TRect;
begin
GetExtent(R);
R.B.Y := R.A.Y + 1;
MenuBar := New( PMenuBar, Init( R, NewMenu(
NewSubMenu( '~F~ile', hcNoContext, NewMenu(
NewItem( '~O~pen','F3', kbF3, cmFileOpen,
hcNoContext,
nil )),
NewSubMenu( '~R~un', hcNoContext,
NewMenu(
NewItem( '~R~un','Ctrl-F9', kbCtrlF9,
cmRun, hcNoContext,
NewItem( '~G~o to cursor','F4', kbF4,
cmGoToCursor, hcNoContext,
NewItem( '~T~race into', 'F7', kbF7,
cmTraceInto, hcNoContext,
NewItem( '~S~tep over', 'F8', kbF8,
cmStepOver, hcNoContext,
NewItem( '~V~iew glyph', 'F9', kbF9,
cmViewGlyph, hcNoContext,
nil
)
)
)
)
)
),
nil
)))));
end;
procedure TMyApp.HandleEvent( var Event : TEvent );
var
Adr : Long;
begin
if debug_mode = view_glyph then
begin
case Event.What of
evKeyDown : case Event.KeyCode of
kbF2 : begin
display_outline := not display_outline;
if not Render_Magnified then
Exit_Viewer;
end;
kbESC : Exit_Viewer;
end;
end;
ClearEvent( Event );
exit;
end;
inherited HandleEvent(Event);
case Event.What of
evCommand : case Event.Command of
cmNewWin : NewWindow;
cmGoToCursor : begin
if etat = etat_Termine then exit;
Event.Command := cmQueryCursorAddr;
Event.InfoPtr := @Adr;
CW^.HandleEvent( Event );
Set_Break( Volatiles,
exec^.curRange,
Adr );
New_Execution;
Execute_Loop;
ReFocus;
end;
cmTraceInto : begin
if etat = etat_termine then exit;
New_Execution;
Single_Step;
ReFocus;
end;
cmStepOver : begin
if etat = etat_termine then exit;
New_Execution;
with exec^ do
case code^[IP] of
$2A, (* LOOPCALL *)
$2B : (* CALL *)
begin
Set_Break( Volatiles,
exec^.curRange,
exec^.IP +
Get_Length( exec^.Code,
exec^.IP ) );
Execute_Loop;
end;
else
Single_Step;
end;
ReFocus;
end;
cmViewGlyph :
Enter_Viewer;
else
exit;
end;
else
exit;
end;
ClearEvent(Event);
end;
constructor TMyApp.Init;
begin
inherited Init;
SetScreenMode( smCo80 + smFont8x8 );
NewWindow;
end;
(*******************************************************************
*
* Function : LoadTrueTypeChar
*
* Description :
*
* Notes :
*
*****************************************************************)
Function LoadTrueTypeChar( index : integer ) : boolean;
var
j, load_flag : int;
rc : TT_Error;
begin
LoadTrueTypeChar := FALSE;
(*
if hint_glyph then load_flag := TT_Load_Scale_Glyph or TT_Load_Hint_Glyph
else load_flag := TT_Load_Scale_Glyph;
*)
load_flag := TT_Load_Scale_Glyph or TT_Load_Hint_Glyph or TT_Load_Debug;
rc := TT_Load_Glyph( the_instance,
the_glyph,
index,
load_flag );
if rc <> TT_Err_Ok then exit;
LoadTrueTypeChar := TRUE;
end;
procedure Usage;
begin
Writeln('Simple Library Debugger -- part of the FreeType project');
Writeln('-----------------------------------------------------');
Writeln;
Writeln(' Usage : debugger glyph_number point_size fontfile[.ttf]');
Writeln;
halt(2);
end;
var
Code : Int;
begin
if ParamCount <> 3 then
Usage;
val( ParamStr(1), glyph_number, Code );
if Code <> 0 then
Usage;
val( ParamStr(2), point_size, Code );
if Code <> 0 then
Usage;
filename := ParamStr(3);
if Pos( '.', filename ) = 0 then filename := filename + '.ttf';
TT_Init_FreeType;
error := TT_Open_Face( filename, the_face );
if error <> TT_Err_Ok then
begin
Writeln('Could not open file ',filename );
halt(1);
end;
face := PFace(the_face.z);
error := TT_New_Glyph( the_face, the_glyph );
if error <> TT_Err_Ok then
begin
Writeln('ERROR : Could not get glyph' );
Check_Error(error);
end;
glyph2 := PGlyph( the_glyph.z );
error := TT_New_Glyph( the_face, the_glyph );
if error <> TT_Err_Ok then
begin
Writeln('ERROR : Could not get glyph' );
Check_Error(error);
end;
glyph := PGlyph( the_glyph.z );
error := TT_New_Instance( the_face, the_instance );
if error <> TT_Err_Ok then
begin
Writeln('ERROR: Could not create new instance' );
Check_Error(error);
end;
instance := PInstance(the_instance.z);
exec := New_Context( instance );
if exec = nil then
begin
Writeln( 'could not create execution context' );
halt(1);
end;
instance^.debug := true;
instance^.context := exec;
TT_Set_Instance_Resolutions( the_instance, 96, 96 );
{$IFDEF DEBUG_CVT}
exec^.curRange := 1;
(* code taken from freetype.pas *)
with instance^.metrics do
begin
x_scale1 := ( Long(point_size*64) * x_resolution ) div 72;
x_scale2 := instance^.owner^.fontHeader.units_per_EM;
y_scale1 := ( Long(point_size*64) * y_resolution ) div 72;
y_scale2 := x_scale2;
if instance^.owner^.fontHeader.flags and 8 <> 0 then
begin
x_scale1 := (x_scale1 + 32) and -64;
y_scale1 := (y_scale1 + 32) and -64;
end;
x_ppem := x_scale1 div 64;
y_ppem := y_scale1 div 64;
end;
instance^.metrics.pointsize := point_size*64;
instance^.valid := False;
if Instance_Reset( instance, true ) then
Panic1('Could not reset instance before executing CVT');
{$ELSE}
error := TT_Set_Instance_PointSize( the_instance, point_size );
if error <> TT_Err_Ok then
begin
Writeln('Could not execute CVT program' );
Check_Error(error);
end;
{$ENDIF}
Init_Engine;
{$IFNDEF DEBUG_CVT}
if not LoadTrueTypeChar( glyph_number ) then
begin
Writeln('Error while loading glyph' );
halt(1);
end;
{$ENDIF}
exec^.instruction_trap := true;
{$IFNDEF DEBUG_CVT}
(* Run_Context( exec, true ); *)
{$ENDIF}
Initialize;
MyApp.Init;
MyApp.Run;
MyApp.Done;
TT_Done_FreeType;
end.

551
pascal/test/dump.pas Normal file
View File

@@ -0,0 +1,551 @@
{***************************************************************************}
{* *}
{* FreeType Font Tester. *}
{* *}
{* This program is used to compare computed advance widths with the *}
{* values present in the "hdmx" table. It is now useless but remains *}
{* a good base for other quick font metrics checkers.. *}
{* *}
{* This source code has been compiled and run under both Virtual Pascal *}
{* on OS/2 and Borland's BP7. *}
{* *}
{***************************************************************************}
program Dump;
uses Crt,
Dos,
{$IFDEF OS2}
Use32,
{$ENDIF}
GMain,
GEvents,
GDriver,
FreeType,
TTCalc,
TTObjs,
TTTables;
{ &PMTYPE NOVIO}
{$DEFINE DEBUG}
type
TPathName = string[128];
const
Precis = 64;
Precis2 = Precis div 2;
PrecisAux = 1024;
Profile_Buff_Size = 32000;
Max_Files = 1024;
var
face : TT_Face;
instance : TT_Instance;
glyph : TT_Glyph;
metrics : TT_Glyph_Metrics;
imetrics : TT_Instance_Metrics;
props : TT_Face_Properties;
ymin, ymax, xmax, xmin, xsize : longint;
res, old_res : int;
numPoints, numContours : int;
Bit : TT_Raster_Map;
Rotation : int; (* Angle modulo 1024 *)
num_glyphs : int;
error : TT_Error;
gray_level : Boolean;
display_outline : boolean;
hint_glyph : boolean;
scan_type : Byte;
old_glyph : int;
cur_glyph : int;
scale_shift : Int;
grayLines : array[0..2048] of Byte;
filenames : array[0..Max_Files-1] of ^TPathName;
(*******************************************************************
*
* Function : Set_Raster_Area
*
*****************************************************************)
procedure Set_Raster_Area;
begin
Bit.rows := vio_Height;
Bit.width := vio_Width;
Bit.flow := TT_Flow_Up;
if gray_level then
Bit.cols := Bit.width
else
Bit.cols := (Bit.width+7) div 8;
Bit.size := Bit.rows * Bit.cols;
end;
(*******************************************************************
*
* Function : Clear_Data
*
*****************************************************************)
procedure Clear_Data;
begin
if gray_level then
fillchar( Bit.buffer^, Bit.size, gray_palette[0] )
else
fillchar( Bit.buffer^, Bit.size, 0 );
end;
(*******************************************************************
*
* Function : Init_Engine
*
*****************************************************************)
procedure Init_Engine( maxRes : Int );
begin
Set_Raster_Area;
GetMem( Bit.buffer, Bit.size );
Clear_Data;
end;
(*******************************************************************
*
* Function : Reset_Scale
*
*****************************************************************)
function Reset_Scale( res : Int ) : Boolean;
begin
error := TT_Set_Instance_Pointsize( instance, res );
Reset_Scale := (error = TT_Err_Ok);
end;
procedure Split( Original : String;
var Base : String;
var Name : String );
var
n : integer;
begin
n := length(Original);
while ( n > 0 ) do
if ( Original[n] = '\' ) or
( Original[n] = '/' ) then
begin
Base := Copy( Original, 1, n-1 );
Name := Copy( Original, n+1, length(Original) );
exit;
end
else
dec(n);
Base := '';
Name := Original;
end;
(*******************************************************************
*
* Function : LoadTrueTypeChar
*
* Description : Loads a single glyph into the xcoord, ycoord and
* flag arrays, from the instance data.
*
*****************************************************************)
Function LoadTrueTypeChar( index : integer;
hint : boolean ) : boolean;
var
j, load_flag : int;
result : TT_Error;
begin
LoadTrueTypeChar := True;
if hint then load_flag := TT_Load_Scale_Glyph or TT_Load_Hint_Glyph
else load_flag := TT_Load_Scale_Glyph;
result := TT_Load_Glyph( instance,
glyph,
index,
load_flag );
if result <> TT_Err_Ok then
exit;
LoadTrueTypeChar := False;
end;
var
Error_String : String;
ine : Int;
procedure Dump_AW( _face : TT_Face );
var
i, j, n : integer;
x, y : longint;
start_x,
start_y,
step_x,
step_y : longint;
fail : Int;
face : PFace;
rec : PHdmx_Record;
begin
face := PFace(_face.z);
rec := nil;
for n := 0 to face^.hdmx.num_records-1 do
if face^.hdmx.records^[n].ppem = imetrics.x_ppem then
rec := @face^.hdmx.records^[n];
if rec = nil then
begin
Writeln('Pas de hdmx record pour ', imetrics.x_ppem, ' ppem');
exit;
end;
ine := 0;
while ine < num_glyphs do
begin
if not LoadTrueTypeChar( ine, true ) then
begin
TT_Get_Glyph_Metrics( glyph, metrics );
x := metrics.advance div 64;
if rec^.widths^[ine] <> x then
begin
Write( '(',ine:3,':',rec^.widths^[ine]:2,' ',x:2,')' );
end;
end;
inc( ine );
end;
Writeln;
Writeln;
end;
procedure Erreur( s : String );
begin
Restore_Screen;
Writeln( 'Error : ', s, ', error code = ', error );
Halt(1);
end;
procedure Usage;
begin
Writeln('Simple TrueType Glyphs viewer - part of the FreeType project' );
Writeln;
Writeln('Usage : ',paramStr(0),' FontName[.TTF]');
Halt(1);
end;
var
i: integer;
heure,
min1,
min2,
sec1,
sec2,
cent1,
cent2 :
{$IFDEF OS2}
longint;
{$ELSE}
word;
{$ENDIF}
C : Char;
Filename : String;
label Fin;
var
Fail : Int;
glyphStr : String[4];
ev : Event;
Code : Int;
init_memory, end_memory : LongInt;
num_args : Integer;
point_size : Integer;
num_files : Integer;
cur_file : Integer;
first_arg : Int;
sortie : Boolean;
base : string;
name : string;
SRec : SearchRec;
begin
TextMode( co80+Font8x8 );
TT_Init_FreeType;
num_args := ParamCount;
if num_args = 0 then
Usage;
first_arg := 1;
gray_level := False;
if ParamStr(first_arg) = '-g' then
begin
inc( first_arg );
gray_level := True;
end;
if first_arg > num_args+1 then
Usage;
val( ParamStr(first_arg), point_size, Code );
if Code <> 0 then
point_size := 24
else
inc( first_arg );
num_files := 0;
while first_arg <= num_args do
begin
Split( ParamStr(first_arg), base, name );
if base <> '' then
base := base + '\';
FindFirst( base+name, Archive+ReadOnly+Hidden, SRec );
if DosError <> 0 then
FindFirst( base+name+'.ttf', AnyFile, SRec );
while (DosError = 0) and (num_files < Max_Files) do
begin
GetMem( filenames[num_files], length(base)+length(SRec.Name)+1 );
filenames[num_files]^ := base + SRec.Name;
inc( num_files );
FindNext( SRec );
end;
{$IFDEF OS2}
FindClose( SRec );
{$ENDIF}
inc( first_arg );
end;
cur_file := 0;
if num_files = 0 then
begin
Writeln('Could not find file(s)');
Halt(3);
end;
(*
if gray_level then
begin
if not Set_Graph_Screen( Graphics_Mode_Gray ) then
Erreur( 'could not set grayscale graphics mode' );
end
else
begin
if not Set_Graph_Screen( Graphics_Mode_Mono ) then
Erreur( 'could not set mono graphics mode' );
end;
*)
Init_Engine( point_size );
repeat
FileName := Filenames[cur_file]^;
if Pos('.',FileName) = 0 then FileName:=FileName+'.TTF';
error := TT_Open_Face( filename, face );
if error <> TT_Err_Ok then
Erreur( 'Could not open '+filename );
TT_Get_Face_Properties( face, props );
num_glyphs := props.num_Glyphs;
i := length(FileName);
while (i > 1) and (FileName[i] <> '\') do dec(i);
FileName := Copy( FileName, i+1, length(FileName) );
error := TT_New_Glyph( face, glyph );
if error <> TT_Err_Ok then
Erreur('Could not create glyph container');
error := TT_New_Instance( face, instance );
if error <> TT_Err_Ok then
Erreur('Could not create instance');
Rotation := 0;
Fail := 0;
res := point_size;
scan_type := 2;
if ( gray_level ) then scale_shift := 1
else scale_shift := 0;
Reset_Scale( res );
display_outline := true;
hint_glyph := true;
old_glyph := -1;
old_res := res;
cur_glyph := 0;
sortie := false;
Repeat
(*
if Render_ABC( cur_glyph ) then
inc( Fail )
else
Display_Bitmap_On_Screen( Bit.Buffer^, Bit.rows, Bit.cols );
Clear_Data;
Print_XY( 0, 0, FileName );
TT_Get_Instance_Metrics( instance, imetrics );
Print_Str(' point size = ');
Str( imetrics.pointSize:3, glyphStr );
Print_Str( glyphStr );
Print_Str(' glyph = ');
Str( cur_glyph, glyphStr );
Print_Str( glyphStr );
Print_XY( 0, 1, 'Hinting (''z'') : ' );
if hint_glyph then Print_Str('on ')
else Print_Str('off');
Print_XY( 0, 2, 'scan type(''e'') : ' );
case scan_type of
0 : Print_Str('none ');
1 : Print_Str('level 1');
2 : Print_Str('level 2');
4 : Print_Str('level 4');
5 : Print_Str('level 5');
end;
*)
TT_Get_Instance_Metrics( instance, imetrics );
Writeln( Filename,' ',imetrics.pointsize,' pts = ',imetrics.x_ppem,' ppem' );
Dump_AW( face );
Get_Event(ev);
case ev.what of
event_Quit : goto Fin;
event_Keyboard : case char(ev.info) of
'n' : begin
sortie := true;
if cur_file+1 < num_files then
inc( cur_file );
end;
'p' : begin
sortie := true;
if cur_file > 1 then
dec( cur_file );
end;
'z' : hint_glyph := not hint_glyph;
'e' : begin
inc( scan_type );
if scan_type = 3 then scan_type := 4;
if scan_type >= 6 then scan_type := 0;
end;
end;
event_Scale_Glyph : begin
inc( res, ev.info );
if res < 1 then res := 1;
if res > 1400 then res := 1400;
end;
event_Change_Glyph : begin
inc( cur_glyph, ev.info );
if cur_glyph < 0 then cur_glyph := 0;
if cur_glyph >= num_glyphs
then cur_glyph := num_glyphs-1;
end;
end;
if res <> old_res then
begin
if not Reset_Scale(res) then
Erreur( 'Could not resize font' );
old_res := res;
end;
Until sortie;
TT_Done_Glyph( glyph );
TT_Close_Face( face );
until false;
Fin:
Restore_Screen;
Writeln;
Writeln('Fails : ', Fail );
TT_Done_FreeType;
end.

123
pascal/test/gdriver.pas Normal file
View File

@@ -0,0 +1,123 @@
(*******************************************************************
*
* gdriver : Graphics utility driver generic interface 1.1
*
* Generic interface for all drivers of the graphics utility used
* by the FreeType test programs.
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg.
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
******************************************************************)
Unit GDriver;
interface
uses GEvents, GMain;
(* Note that we now support an event based model, even with */
/* full-screen modes. It is the responsability of the driver */
/* to map its events to the TEvent structure when called */
/* through Get_Event *)
type
Event = record
what : GEvent; (* event class *)
info : Int; (* event parameter *)
end;
(* the event classes are defined in the file 'gevents.h' included *)
(* by the test programs, not by the graphics utility *)
procedure Get_Event( var ev : Event );
(* get last event. In full-screen modes, a key-stroke must be */
/* translated to an event class with a parameter. *)
function Driver_Set_Graphics( mode : Int ) : boolean;
(* A call to this function must set the graphics mode, the Vio *)
(* variable, as well as the values vio_ScanLineWidth, vio_Width *)
(* and vio_Height *)
function Driver_Restore_Mode : boolean;
(* Restore previous mode or release display buffer/window *)
procedure Driver_Display_Bitmap( var buff; line, col : Int );
(* Display bitmap on screen *)
implementation
{$IFDEF OS2}
uses Os2Base, CRT;
{$I GDRV_OS2.INC}
{$ELSE}
uses CRT;
{$I GDRV_DOS.INC}
{$ENDIF}
type
Translator = record
key : char;
ev_class : GEvent;
ev_info : Int;
end;
const
Num_Translators = 15;
Translators : array[1..Num_Translators] of Translator
= (
(key:#27; ev_class:event_Quit ; ev_info:0),
(key:'x'; ev_class: event_Rotate_Glyph; ev_info: -1),
(key:'c'; ev_class: event_Rotate_Glyph; ev_info: 1),
(key:'v'; ev_class: event_Rotate_Glyph; ev_info: -16),
(key:'b'; ev_class: event_Rotate_Glyph; ev_info: 16),
(key:'9'; ev_class: event_Change_Glyph; ev_info:-100),
(key:'0'; ev_class: event_Change_Glyph; ev_info: 100),
(key:'i'; ev_class: event_Change_Glyph; ev_info: -10),
(key:'o'; ev_class: event_Change_Glyph; ev_info: 10),
(key:'k'; ev_class: event_Change_Glyph; ev_info: -1),
(key:'l'; ev_class: event_Change_Glyph; ev_info: 1),
(key:'+'; ev_class: event_Scale_Glyph; ev_info: 10),
(key:'-'; ev_class: event_Scale_Glyph; ev_info: -10),
(key:'u'; ev_class: event_Scale_Glyph; ev_info: 1),
(key:'j'; ev_class: event_Scale_Glyph; ev_info: -1)
);
procedure Get_Event( var ev : Event );
var
i : Int;
c : char;
begin
c := ReadKey;
for i := 1 to Num_Translators do
begin
if c = translators[i].key then
begin
ev.what := translators[i].ev_class;
ev.info := translators[i].ev_info;
exit;
end;
end;
(* unrecognized keystroke *)
ev.what := event_Keyboard;
ev.info := Int(c);
end;
end.

96
pascal/test/gdrv_dos.inc Normal file
View File

@@ -0,0 +1,96 @@
{ Restores screen to the original state }
function Driver_Restore_Mode: boolean;
begin
asm
mov ax, $0003
int $10
end;
Driver_Restore_Mode := True;
end;
function Driver_Set_Graphics( mode : Int ) : boolean;
var
rc : Int;
begin
Driver_Set_Graphics := False;
rc := 0;
case Mode of
Graphics_Mode_Mono : begin
asm
mov ax, $0012
int $10
end;
Vio_ScanLineWidth := 80;
Vio_Width := 640;
Vio_Height := 480;
end;
Graphics_Mode_Gray : begin
asm
mov ax, $0013
int $10
end;
Vio_ScanLineWidth := 320;
Vio_Width := 320;
Vio_Height := 200;
(* default gray palette takes the gray levels *)
(* the standard VGA 256 colors mode *)
gray_palette[0] := 0;
gray_palette[1] := 23;
gray_palette[2] := 27;
gray_palette[3] := 29;
gray_palette[4] := 31;
end;
else
rc := -1;
end;
if rc <> 0 then exit;
Vio := @Mem[$A000:0];
Driver_Set_Graphics := True;
end;
procedure Driver_Display_Bitmap; assembler;
asm
push ds
push bp
les di, [Vio]
cld
mov cx,[Vio_ScanLineWidth]
mov bx,[col]
mov ax,[line]
dec ax
mul cx
add di,ax
mov dx,[line]
lds si,[Buff]
mov bp,bx
add bx,cx
@1:
mov cx,bp
rep movsb
sub di,bx
dec dx
jnz @1
pop bp
pop ds
end;

148
pascal/test/gdrv_os2.inc Normal file
View File

@@ -0,0 +1,148 @@
{$IFDEF DYNAMIC_VERSION}
{$Dynamic System}
{$L VPRTL.LIB}
{$ENDIF}
type
Ptr16Rec = record
Ofs,Sel: SmallWord;
end;
var
OrgMode : VioModeInfo;
VioBufOfs : Longint;
Status : SmallWord;
{ BIOS Video Mode
#13 }
const
VioMode_640x480x16 : VioModeInfo =
( cb: SizeOf(VioModeInfo);
fbType: vgmt_Other + vgmt_Graphics;
Color: colors_16;
Col: 80;
Row: 35;
HRes: 640;
VRes: 480
);
VioMode_320x200x256 : VioModeInfo =
( cb: SizeOf(VioModeInfo);
fbType: vgmt_Other + vgmt_Graphics;
Color: colors_256;
Col: 40;
Row: 25;
HRes: 320;
VRes: 200
);
VioBuf: VioPhysBuf =
( pBuf: Ptr($A0000);
cb: 64*1024
);
{ Restores screen to the original state }
function Driver_Restore_Mode: boolean;
begin
VioSetMode(OrgMode, 0);
Driver_Restore_Mode := True;
end;
function Driver_Set_Graphics( mode : Int )
: boolean;
var
rc : Int;
begin
Driver_Set_Graphics := False;
{ Save original video mode }
OrgMode.cb := SizeOf(VioModeInfo);
VioGetMode(OrgMode, 0);
case Mode of
Graphics_Mode_Mono : begin
rc := VioSetMode( VioMode_640x480x16, 0 );
Vio_ScanLineWidth := 80;
Vio_Width := 640;
Vio_Height := 480;
end;
Graphics_Mode_Gray : begin
rc := VioSetMode( VioMode_320x200x256, 0 );
Vio_ScanLineWidth := 320;
Vio_Width := 320;
Vio_Height := 200;
(* default gray palette takes the gray levels *)
(* the standard VGA 256 colors mode *)
gray_palette[0] := 0;
gray_palette[1] := 23;
gray_palette[2] := 27;
gray_palette[3] := 29;
gray_palette[4] := 31;
end;
else
rc := -1;
end;
{ Set VGA 640x400x16
video mode }
if rc <> 0 then exit;
{ Get selector for physical video buffer }
if VioGetPhysBuf(VioBuf, 0) <> 0 then exit;
{ Make flat pointer that points to the physical video buffer}
Ptr16Rec(VioBufOfs).Ofs := 0;
Ptr16Rec(VioBufOfs).Sel := VioBuf.Sel;
SelToFlat(Pointer(VioBufOfs));
{ Clear the screen. Unlike function 0 of the BIOS INT 10h }
{ VioSetMode doesn't clear the screen. }
FillChar(Pointer(VioBufOfs)^,64*1024,0);
Vio := PVioScreenBuffer(VioBufOfs);
Driver_Set_Graphics := True;
end;
procedure Driver_Display_Bitmap; assembler;
asm
push esi
push edi
push ebx
push ecx
mov esi,[Buff]
mov ecx,[Vio_ScanLineWidth]
mov ebx,[Col]
mov eax,[Line]
dec eax
mul ecx
mov edi,[VioBufOfs]
add edi,eax
mov edx,[line]
add ebx,[Vio_ScanLineWidth]
@1:
mov ecx,[col]
rep movsb
sub edi,ebx
dec edx
jnz @1
pop ecx
pop ebx
pop edi
pop esi
end;

42
pascal/test/gevents.pas Normal file
View File

@@ -0,0 +1,42 @@
(*******************************************************************
*
* gevents test programs events definition 1.1
*
* This file defines the events used by the FreeType test programs
* It is _not_ included by 'gmain.c'. This file is also used by the
* drivers to translate their own events in GEvents.
*
* Not a very good design, but we're not rewriting X..
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg.
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
******************************************************************)
Unit GEvents;
interface
type
GEvent = (
event_None,
event_Quit, (* Quit program *)
event_Keyboard, (* unknown keystroke *)
event_Change_Glyph,
event_Rotate_Glyph,
event_Scale_Glyph,
event_Change_ScanType,
event_Change_Instructions
);
implementation
end.

474
pascal/test/gmain.pas Normal file
View File

@@ -0,0 +1,474 @@
(*******************************************************************
*
* gmain graphics utility main interface 1.1
*
* This file defines a common interface, implemented in the body
* file 'gmain.c'. It relies on system dependent driver files,
* like 'gfs_os.c', whose interface is described in 'gdriver.h'.
*
* Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg.
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
******************************************************************)
Unit GMain;
interface
const
Graphics_Mode_Mono = 1;
Graphics_Mode_Gray = 2;
type
TVioScreenBuffer = array[0..0] of Byte;
PVioScreenBuffer = ^TVioScreenBuffer;
{$IFDEF OS2}
Int = LongInt;
{$ELSE}
Int = Integer;
{$ENDIF}
var
Vio : PVioScreenBuffer;
(* pointer to VRAM or display buffer *)
vio_ScanLineWidth : Int;
vio_Width : Int;
vio_Height : Int;
gray_palette : array[0..4] of Byte; (* gray palette *)
gcursor_x : int;
gcursor_y : int;
gwindow_width : int;
gwindow_height : int;
function Set_Graph_Screen( mode : int ) : boolean;
(* Set a Graphics Mode, chosen from the Graphics_Mode_xxx list *)
function Restore_Screen : boolean;
(* Restore a previous ( or text ) video mode *)
procedure Display_Bitmap_On_Screen( var buff; line, col : Int );
(* display bitmap of 'line' line, and 'col' columns ( each *)
(* column mode of 1 byte *)
procedure Goto_XY( x, y : int );
procedure Print_Str( str : string );
procedure Print_XY ( x, y : int; str : string );
implementation
uses GDriver;
type
TFunction_8x8 = procedure( x, y : Int; c : char );
TByte = array[0..0] of Byte;
PByte = ^TByte;
var
Current_Mode : Byte;
Print_8x8 : TFunction_8x8;
const
Font_8x8 : array[0..2047] of Byte
= (
$00, $00, $00, $00, $00, $00, $00, $00,
$7E, $81, $A5, $81, $BD, $99, $81, $7E,
$7E, $FF, $DB, $FF, $C3, $E7, $FF, $7E,
$6C, $FE, $FE, $FE, $7C, $38, $10, $00,
$10, $38, $7C, $FE, $7C, $38, $10, $00,
$38, $7C, $38, $FE, $FE, $92, $10, $7C,
$00, $10, $38, $7C, $FE, $7C, $38, $7C,
$00, $00, $18, $3C, $3C, $18, $00, $00,
$FF, $FF, $E7, $C3, $C3, $E7, $FF, $FF,
$00, $3C, $66, $42, $42, $66, $3C, $00,
$FF, $C3, $99, $BD, $BD, $99, $C3, $FF,
$0F, $07, $0F, $7D, $CC, $CC, $CC, $78,
$3C, $66, $66, $66, $3C, $18, $7E, $18,
$3F, $33, $3F, $30, $30, $70, $F0, $E0,
$7F, $63, $7F, $63, $63, $67, $E6, $C0,
$99, $5A, $3C, $E7, $E7, $3C, $5A, $99,
$80, $E0, $F8, $FE, $F8, $E0, $80, $00,
$02, $0E, $3E, $FE, $3E, $0E, $02, $00,
$18, $3C, $7E, $18, $18, $7E, $3C, $18,
$66, $66, $66, $66, $66, $00, $66, $00,
$7F, $DB, $DB, $7B, $1B, $1B, $1B, $00,
$3E, $63, $38, $6C, $6C, $38, $86, $FC,
$00, $00, $00, $00, $7E, $7E, $7E, $00,
$18, $3C, $7E, $18, $7E, $3C, $18, $FF,
$18, $3C, $7E, $18, $18, $18, $18, $00,
$18, $18, $18, $18, $7E, $3C, $18, $00,
$00, $18, $0C, $FE, $0C, $18, $00, $00,
$00, $30, $60, $FE, $60, $30, $00, $00,
$00, $00, $C0, $C0, $C0, $FE, $00, $00,
$00, $24, $66, $FF, $66, $24, $00, $00,
$00, $18, $3C, $7E, $FF, $FF, $00, $00,
$00, $FF, $FF, $7E, $3C, $18, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $00,
$18, $3C, $3C, $18, $18, $00, $18, $00,
$6C, $6C, $6C, $00, $00, $00, $00, $00,
$6C, $6C, $FE, $6C, $FE, $6C, $6C, $00,
$18, $7E, $C0, $7C, $06, $FC, $18, $00,
$00, $C6, $CC, $18, $30, $66, $C6, $00,
$38, $6C, $38, $76, $DC, $CC, $76, $00,
$30, $30, $60, $00, $00, $00, $00, $00,
$18, $30, $60, $60, $60, $30, $18, $00,
$60, $30, $18, $18, $18, $30, $60, $00,
$00, $66, $3C, $FF, $3C, $66, $00, $00,
$00, $18, $18, $7E, $18, $18, $00, $00,
$00, $00, $00, $00, $00, $18, $18, $30,
$00, $00, $00, $7E, $00, $00, $00, $00,
$00, $00, $00, $00, $00, $18, $18, $00,
$06, $0C, $18, $30, $60, $C0, $80, $00,
$7C, $CE, $DE, $F6, $E6, $C6, $7C, $00,
$30, $70, $30, $30, $30, $30, $FC, $00,
$78, $CC, $0C, $38, $60, $CC, $FC, $00,
$78, $CC, $0C, $38, $0C, $CC, $78, $00,
$1C, $3C, $6C, $CC, $FE, $0C, $1E, $00,
$FC, $C0, $F8, $0C, $0C, $CC, $78, $00,
$38, $60, $C0, $F8, $CC, $CC, $78, $00,
$FC, $CC, $0C, $18, $30, $30, $30, $00,
$78, $CC, $CC, $78, $CC, $CC, $78, $00,
$78, $CC, $CC, $7C, $0C, $18, $70, $00,
$00, $18, $18, $00, $00, $18, $18, $00,
$00, $18, $18, $00, $00, $18, $18, $30,
$18, $30, $60, $C0, $60, $30, $18, $00,
$00, $00, $7E, $00, $7E, $00, $00, $00,
$60, $30, $18, $0C, $18, $30, $60, $00,
$3C, $66, $0C, $18, $18, $00, $18, $00,
$7C, $C6, $DE, $DE, $DC, $C0, $7C, $00,
$30, $78, $CC, $CC, $FC, $CC, $CC, $00,
$FC, $66, $66, $7C, $66, $66, $FC, $00,
$3C, $66, $C0, $C0, $C0, $66, $3C, $00,
$F8, $6C, $66, $66, $66, $6C, $F8, $00,
$FE, $62, $68, $78, $68, $62, $FE, $00,
$FE, $62, $68, $78, $68, $60, $F0, $00,
$3C, $66, $C0, $C0, $CE, $66, $3A, $00,
$CC, $CC, $CC, $FC, $CC, $CC, $CC, $00,
$78, $30, $30, $30, $30, $30, $78, $00,
$1E, $0C, $0C, $0C, $CC, $CC, $78, $00,
$E6, $66, $6C, $78, $6C, $66, $E6, $00,
$F0, $60, $60, $60, $62, $66, $FE, $00,
$C6, $EE, $FE, $FE, $D6, $C6, $C6, $00,
$C6, $E6, $F6, $DE, $CE, $C6, $C6, $00,
$38, $6C, $C6, $C6, $C6, $6C, $38, $00,
$FC, $66, $66, $7C, $60, $60, $F0, $00,
$7C, $C6, $C6, $C6, $D6, $7C, $0E, $00,
$FC, $66, $66, $7C, $6C, $66, $E6, $00,
$7C, $C6, $E0, $78, $0E, $C6, $7C, $00,
$FC, $B4, $30, $30, $30, $30, $78, $00,
$CC, $CC, $CC, $CC, $CC, $CC, $FC, $00,
$CC, $CC, $CC, $CC, $CC, $78, $30, $00,
$C6, $C6, $C6, $C6, $D6, $FE, $6C, $00,
$C6, $C6, $6C, $38, $6C, $C6, $C6, $00,
$CC, $CC, $CC, $78, $30, $30, $78, $00,
$FE, $C6, $8C, $18, $32, $66, $FE, $00,
$78, $60, $60, $60, $60, $60, $78, $00,
$C0, $60, $30, $18, $0C, $06, $02, $00,
$78, $18, $18, $18, $18, $18, $78, $00,
$10, $38, $6C, $C6, $00, $00, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $FF,
$30, $30, $18, $00, $00, $00, $00, $00,
$00, $00, $78, $0C, $7C, $CC, $76, $00,
$E0, $60, $60, $7C, $66, $66, $DC, $00,
$00, $00, $78, $CC, $C0, $CC, $78, $00,
$1C, $0C, $0C, $7C, $CC, $CC, $76, $00,
$00, $00, $78, $CC, $FC, $C0, $78, $00,
$38, $6C, $64, $F0, $60, $60, $F0, $00,
$00, $00, $76, $CC, $CC, $7C, $0C, $F8,
$E0, $60, $6C, $76, $66, $66, $E6, $00,
$30, $00, $70, $30, $30, $30, $78, $00,
$0C, $00, $1C, $0C, $0C, $CC, $CC, $78,
$E0, $60, $66, $6C, $78, $6C, $E6, $00,
$70, $30, $30, $30, $30, $30, $78, $00,
$00, $00, $CC, $FE, $FE, $D6, $D6, $00,
$00, $00, $B8, $CC, $CC, $CC, $CC, $00,
$00, $00, $78, $CC, $CC, $CC, $78, $00,
$00, $00, $DC, $66, $66, $7C, $60, $F0,
$00, $00, $76, $CC, $CC, $7C, $0C, $1E,
$00, $00, $DC, $76, $62, $60, $F0, $00,
$00, $00, $7C, $C0, $70, $1C, $F8, $00,
$10, $30, $FC, $30, $30, $34, $18, $00,
$00, $00, $CC, $CC, $CC, $CC, $76, $00,
$00, $00, $CC, $CC, $CC, $78, $30, $00,
$00, $00, $C6, $C6, $D6, $FE, $6C, $00,
$00, $00, $C6, $6C, $38, $6C, $C6, $00,
$00, $00, $CC, $CC, $CC, $7C, $0C, $F8,
$00, $00, $FC, $98, $30, $64, $FC, $00,
$1C, $30, $30, $E0, $30, $30, $1C, $00,
$18, $18, $18, $00, $18, $18, $18, $00,
$E0, $30, $30, $1C, $30, $30, $E0, $00,
$76, $DC, $00, $00, $00, $00, $00, $00,
$00, $10, $38, $6C, $C6, $C6, $FE, $00,
$7C, $C6, $C0, $C6, $7C, $0C, $06, $7C,
$00, $CC, $00, $CC, $CC, $CC, $76, $00,
$1C, $00, $78, $CC, $FC, $C0, $78, $00,
$7E, $81, $3C, $06, $3E, $66, $3B, $00,
$CC, $00, $78, $0C, $7C, $CC, $76, $00,
$E0, $00, $78, $0C, $7C, $CC, $76, $00,
$30, $30, $78, $0C, $7C, $CC, $76, $00,
$00, $00, $7C, $C6, $C0, $78, $0C, $38,
$7E, $81, $3C, $66, $7E, $60, $3C, $00,
$CC, $00, $78, $CC, $FC, $C0, $78, $00,
$E0, $00, $78, $CC, $FC, $C0, $78, $00,
$CC, $00, $70, $30, $30, $30, $78, $00,
$7C, $82, $38, $18, $18, $18, $3C, $00,
$E0, $00, $70, $30, $30, $30, $78, $00,
$C6, $10, $7C, $C6, $FE, $C6, $C6, $00,
$30, $30, $00, $78, $CC, $FC, $CC, $00,
$1C, $00, $FC, $60, $78, $60, $FC, $00,
$00, $00, $7F, $0C, $7F, $CC, $7F, $00,
$3E, $6C, $CC, $FE, $CC, $CC, $CE, $00,
$78, $84, $00, $78, $CC, $CC, $78, $00,
$00, $CC, $00, $78, $CC, $CC, $78, $00,
$00, $E0, $00, $78, $CC, $CC, $78, $00,
$78, $84, $00, $CC, $CC, $CC, $76, $00,
$00, $E0, $00, $CC, $CC, $CC, $76, $00,
$00, $CC, $00, $CC, $CC, $7C, $0C, $F8,
$C3, $18, $3C, $66, $66, $3C, $18, $00,
$CC, $00, $CC, $CC, $CC, $CC, $78, $00,
$18, $18, $7E, $C0, $C0, $7E, $18, $18,
$38, $6C, $64, $F0, $60, $E6, $FC, $00,
$CC, $CC, $78, $30, $FC, $30, $FC, $30,
$F8, $CC, $CC, $FA, $C6, $CF, $C6, $C3,
$0E, $1B, $18, $3C, $18, $18, $D8, $70,
$1C, $00, $78, $0C, $7C, $CC, $76, $00,
$38, $00, $70, $30, $30, $30, $78, $00,
$00, $1C, $00, $78, $CC, $CC, $78, $00,
$00, $1C, $00, $CC, $CC, $CC, $76, $00,
$00, $F8, $00, $B8, $CC, $CC, $CC, $00,
$FC, $00, $CC, $EC, $FC, $DC, $CC, $00,
$3C, $6C, $6C, $3E, $00, $7E, $00, $00,
$38, $6C, $6C, $38, $00, $7C, $00, $00,
$18, $00, $18, $18, $30, $66, $3C, $00,
$00, $00, $00, $FC, $C0, $C0, $00, $00,
$00, $00, $00, $FC, $0C, $0C, $00, $00,
$C6, $CC, $D8, $36, $6B, $C2, $84, $0F,
$C3, $C6, $CC, $DB, $37, $6D, $CF, $03,
$18, $00, $18, $18, $3C, $3C, $18, $00,
$00, $33, $66, $CC, $66, $33, $00, $00,
$00, $CC, $66, $33, $66, $CC, $00, $00,
$22, $88, $22, $88, $22, $88, $22, $88,
$55, $AA, $55, $AA, $55, $AA, $55, $AA,
$DB, $F6, $DB, $6F, $DB, $7E, $D7, $ED,
$18, $18, $18, $18, $18, $18, $18, $18,
$18, $18, $18, $18, $F8, $18, $18, $18,
$18, $18, $F8, $18, $F8, $18, $18, $18,
$36, $36, $36, $36, $F6, $36, $36, $36,
$00, $00, $00, $00, $FE, $36, $36, $36,
$00, $00, $F8, $18, $F8, $18, $18, $18,
$36, $36, $F6, $06, $F6, $36, $36, $36,
$36, $36, $36, $36, $36, $36, $36, $36,
$00, $00, $FE, $06, $F6, $36, $36, $36,
$36, $36, $F6, $06, $FE, $00, $00, $00,
$36, $36, $36, $36, $FE, $00, $00, $00,
$18, $18, $F8, $18, $F8, $00, $00, $00,
$00, $00, $00, $00, $F8, $18, $18, $18,
$18, $18, $18, $18, $1F, $00, $00, $00,
$18, $18, $18, $18, $FF, $00, $00, $00,
$00, $00, $00, $00, $FF, $18, $18, $18,
$18, $18, $18, $18, $1F, $18, $18, $18,
$00, $00, $00, $00, $FF, $00, $00, $00,
$18, $18, $18, $18, $FF, $18, $18, $18,
$18, $18, $1F, $18, $1F, $18, $18, $18,
$36, $36, $36, $36, $37, $36, $36, $36,
$36, $36, $37, $30, $3F, $00, $00, $00,
$00, $00, $3F, $30, $37, $36, $36, $36,
$36, $36, $F7, $00, $FF, $00, $00, $00,
$00, $00, $FF, $00, $F7, $36, $36, $36,
$36, $36, $37, $30, $37, $36, $36, $36,
$00, $00, $FF, $00, $FF, $00, $00, $00,
$36, $36, $F7, $00, $F7, $36, $36, $36,
$18, $18, $FF, $00, $FF, $00, $00, $00,
$36, $36, $36, $36, $FF, $00, $00, $00,
$00, $00, $FF, $00, $FF, $18, $18, $18,
$00, $00, $00, $00, $FF, $36, $36, $36,
$36, $36, $36, $36, $3F, $00, $00, $00,
$18, $18, $1F, $18, $1F, $00, $00, $00,
$00, $00, $1F, $18, $1F, $18, $18, $18,
$00, $00, $00, $00, $3F, $36, $36, $36,
$36, $36, $36, $36, $FF, $36, $36, $36,
$18, $18, $FF, $18, $FF, $18, $18, $18,
$18, $18, $18, $18, $F8, $00, $00, $00,
$00, $00, $00, $00, $1F, $18, $18, $18,
$FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF,
$00, $00, $00, $00, $FF, $FF, $FF, $FF,
$F0, $F0, $F0, $F0, $F0, $F0, $F0, $F0,
$0F, $0F, $0F, $0F, $0F, $0F, $0F, $0F,
$FF, $FF, $FF, $FF, $00, $00, $00, $00,
$00, $00, $76, $DC, $C8, $DC, $76, $00,
$00, $78, $CC, $F8, $CC, $F8, $C0, $C0,
$00, $FC, $CC, $C0, $C0, $C0, $C0, $00,
$00, $00, $FE, $6C, $6C, $6C, $6C, $00,
$FC, $CC, $60, $30, $60, $CC, $FC, $00,
$00, $00, $7E, $D8, $D8, $D8, $70, $00,
$00, $66, $66, $66, $66, $7C, $60, $C0,
$00, $76, $DC, $18, $18, $18, $18, $00,
$FC, $30, $78, $CC, $CC, $78, $30, $FC,
$38, $6C, $C6, $FE, $C6, $6C, $38, $00,
$38, $6C, $C6, $C6, $6C, $6C, $EE, $00,
$1C, $30, $18, $7C, $CC, $CC, $78, $00,
$00, $00, $7E, $DB, $DB, $7E, $00, $00,
$06, $0C, $7E, $DB, $DB, $7E, $60, $C0,
$38, $60, $C0, $F8, $C0, $60, $38, $00,
$78, $CC, $CC, $CC, $CC, $CC, $CC, $00,
$00, $7E, $00, $7E, $00, $7E, $00, $00,
$18, $18, $7E, $18, $18, $00, $7E, $00,
$60, $30, $18, $30, $60, $00, $FC, $00,
$18, $30, $60, $30, $18, $00, $FC, $00,
$0E, $1B, $1B, $18, $18, $18, $18, $18,
$18, $18, $18, $18, $18, $D8, $D8, $70,
$18, $18, $00, $7E, $00, $18, $18, $00,
$00, $76, $DC, $00, $76, $DC, $00, $00,
$38, $6C, $6C, $38, $00, $00, $00, $00,
$00, $00, $00, $18, $18, $00, $00, $00,
$00, $00, $00, $00, $18, $00, $00, $00,
$0F, $0C, $0C, $0C, $EC, $6C, $3C, $1C,
$58, $6C, $6C, $6C, $6C, $00, $00, $00,
$70, $98, $30, $60, $F8, $00, $00, $00,
$00, $00, $3C, $3C, $3C, $3C, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $00
);
{$F+}
procedure Print_8x8_Mono( x, y : Int; c : char );
var
offset, i : Int;
bitm : PByte;
begin
offset := x + y*Vio_ScanLineWidth*8;
bitm := @Font_8x8[ ord(c)*8 ];
for i := 0 to 7 do
begin
Vio^[offset] := bitm^[i];
inc( offset, Vio_ScanLineWidth );
end;
end;
procedure Print_8x8_Gray( x, y : Int; c : char );
var
offset, i, bit : Int;
bitm : PByte;
begin
offset := ( x + y*Vio_ScanLineWidth )*8;
bitm := @font_8x8[ ord(c)*8 ];
for i := 0 to 7 do
begin
bit := $80;
while bit > 0 do
begin
if ( bit and bitm^[i] <> 0 ) then Vio^[offset] := $FF
else Vio^[offset] := $00;
bit := bit shr 1;
inc( offset );
end;
inc( offset, Vio_ScanLineWidth-8 );
end;
end;
{$F-}
function Set_Graph_Screen( mode : Int ): boolean;
begin
Set_Graph_Screen := False;
gcursor_x := 0;
gcursor_y := 0;
case mode of
Graphics_Mode_Mono : begin
if not Driver_Set_Graphics(mode) then exit;
gwindow_width := vio_ScanLineWidth;
gwindow_height := vio_Height div 8;
Print_8x8 := Print_8x8_Mono;
end;
Graphics_Mode_Gray : begin
if not Driver_Set_Graphics(mode) then exit;
gwindow_width := vio_ScanLineWidth div 8;
gwindow_height := vio_Height div 8;
Print_8x8 := Print_8x8_Gray;
end;
else
exit;
end;
Set_Graph_Screen := True;
end;
function Restore_Screen : boolean;
begin
gcursor_x := 0;
gcursor_y := 0;
gwindow_height := 0;
gwindow_width := 0;
Restore_Screen := Driver_Restore_Mode;
end;
procedure Display_Bitmap_On_Screen;
begin
Driver_Display_Bitmap( buff, line, col );
end;
procedure Goto_XY( x, y : Int );
begin
gcursor_x := x;
gcursor_y := y;
end;
procedure Print_Str( str : string );
var
i : Int;
begin
for i := 1 to length(str) do
begin
case str[i] of
#13 : begin
gcursor_x := 0;
inc( gcursor_y );
if gcursor_y > gwindow_height then gcursor_y := 0;
end;
else
Print_8x8( gcursor_x, gcursor_y, str[i] );
inc( gcursor_x );
if gcursor_x >= gwindow_width then
begin
gcursor_x := 0;
inc( gcursor_y );
if gcursor_y >= gwindow_height then gcursor_y := 0;
end
end
end
end;
procedure Print_XY( x, y : Int; str : string );
begin
Goto_XY( x, y );
Print_Str( str );
end;
end.

277
pascal/test/lint.pas Normal file
View File

@@ -0,0 +1,277 @@
{***************************************************************************}
{* *}
{* FreeType Font glyph programs checker *}
{* *}
{* *}
{* This small program will load a TrueType font file and try to *}
{* render it at a given point size. *}
{* *}
{* This version will also catch differences between the engine's *}
{* computed advance widths, and the pre-calc values found in the *}
{* "hdmx" table *}
{* *}
{* This source code has been compiled and run under both Virtual Pascal *}
{* on OS/2 and Borland's BP7. *}
{* *}
{***************************************************************************}
program Abc;
uses Crt,
Common,
{$IFDEF OS2}
Use32,
{$ENDIF}
FreeType,
TTObjs;
const
Precis = 64;
Precis2 = Precis div 2;
PrecisAux = 1024;
Screen_Width = 640;
Screen_Height = 480;
Screen_Cols = Screen_Width div 8;
Screen_Size = Screen_Cols * Screen_Height;
Grid_Width = Screen_Width div 8;
Grid_Height = Screen_Height div 8;
Grid_Cols = Grid_Width div 8;
Grid_Size = Grid_Cols * Grid_Height;
Screen_Center_X = Screen_Width div 2;
Screen_Center_Y = Screen_Height div 2;
Grid_Center_X = Grid_Width div 2;
Grid_Center_Y = Grid_Height div 2;
Profile_Buff_Size = 64000;
var
res, old_res : integer;
numPoints, numContours : integer;
Bitmap_small : TT_Raster_Map;
Bitmap_big : TT_Raster_Map;
Rotation : integer; (* Angle modulo 1024 *)
num_glyphs : integer;
face : TT_Face;
instance : TT_Instance;
glyph : TT_Glyph;
metrics : TT_Glyph_Metrics;
imetrics : TT_Instance_Metrics;
props : TT_Face_Properties;
point_size : integer;
error : TT_Error;
display_outline : boolean;
hint_glyph : boolean;
scan_type : Byte;
old_glyph : integer;
FOut : Text;
(*******************************************************************
*
* Function : LoadTrueTypeChar
*
* Description : Loads a single glyph into the xcoord, ycoord and
* flag arrays, from the instance data.
*
*****************************************************************)
Function LoadTrueTypeChar( index : integer;
hint : boolean ) : TT_Error;
var
j, load_flag : integer;
result : TT_Error;
begin
if hint then load_flag := TT_Load_Scale_Glyph or TT_Load_Hint_Glyph
else load_flag := TT_Load_Scale_Glyph;
result := TT_Load_Glyph( instance,
glyph,
index,
load_flag );
LoadTrueTypeChar := result;
end;
procedure Usage;
begin
Writeln('Simple TrueType Glyphs viewer - part of the FreeType project' );
Writeln;
Writeln('Usage : ',paramStr(0),' size fontname[.ttf] [fontname.. ]');
Writeln;
Halt(1);
end;
var i: integer;
heure,
min1,
min2,
sec1,
sec2,
cent1,
cent2 :
{$IFDEF OS2}
longint;
{$ELSE}
word;
{$ENDIF}
C : Char;
Filename : String;
label Fin;
var
Fail : Integer;
PtSize : Integer;
Param : Integer;
code : Integer;
glyphStr : String[4];
cur_file : Integer;
valid : Boolean;
Mem0 : Longint;
label
Lopo;
begin
Mem0 := MemAvail;
TT_Init_FreeType;
if ParamCount < 2 then Usage;
val( ParamStr(1), point_size, code );
if code <> 0 then Usage;
if ( point_size <= 0 ) then
begin
Writeln('Invalid argument : pointsize must be >= 1');
Usage;
end;
Expand_WildCards( 2, '.ttf' );
for cur_file := 0 to num_arguments-1 do
begin
FileName := arguments[cur_file]^;
if Pos('.',FileName) = 0 then FileName:=FileName+'.TTF';
Write( MemAvail:6, ' ' );
error := TT_Open_Face( filename, face );
i := length(FileName);
while (i > 1) and (FileName[i] <> '\') do dec(i);
FileName := Copy( FileName, i+1, length(FileName) );
Write( cur_file:3,' ', filename:12, ': ' );
if error <> TT_Err_Ok then
begin
Writeln( 'could not open file, error code = ', error );
goto Lopo;
end;
TT_Get_Face_Properties( face, props );
num_glyphs := props.num_Glyphs;
error := TT_New_Glyph( face, glyph );
if error <> TT_Err_Ok then
begin
Writeln( 'could not create glyph, error code = ',
error );
goto Lopo;
end;
error := TT_New_Instance( face, instance );
if error <> TT_Err_Ok then
begin
Writeln( 'could not create instance, error code = ',
error );
goto Lopo;
end;
error := TT_Set_Instance_PointSize( instance, point_size );
if error <> TT_Err_Ok then
begin
Writeln( 'could not set point size, error code = ', error );
goto Lopo;
end;
Fail := 0;
for i := 0 to num_glyphs-1 do
begin
error := LoadTrueTypeChar( i, true );
if error <> TT_Err_Ok then
begin
inc( Fail );
if Fail < 10 then
Writeln( 'error hinting glyph ', i, ', code = ',
error );
end;
{$IFDEF RIEN}
with PGlyph(glyph.z)^ do
begin
if (precalc_width >= 0) and
(precalc_width <> computed_width) then
begin
Write( i:5,' hdmx = ',precalc_width:3 );
Write( ', engine = ',computed_width );
if is_composite then Write( ' (composite)' );
Writeln;
end
end;
{$ENDIF}
end;
if Fail >= 10 then
Writeln( 'there were ',Fail,' failed glyphs' );
if Fail = 0 then
Writeln( 'ok' );
Lopo:
TT_Close_Face( face );
end;
Fin:
Writeln('Memory consumed by lint = ', Mem0 - MemAvail );
TT_Done_FreeType;
Writeln('Memory leaked after engine termination = ', Mem0 - MemAvail );
end.

148
pascal/test/stacktv.pas Normal file
View File

@@ -0,0 +1,148 @@
(* The Turbo Vision Stack Component. Part of the FreeType Debugger *)
unit StackTV;
interface
uses Objects, Views, Drivers, TTTypes, TTObjs, TTDebug;
type
{ TStackView }
{ A Simple stack display }
PStackView = ^TStackView;
TStackView = object( TListViewer )
constructor Init( var Bounds : TRect;
aexec : PExec_Context;
AVScrollBar : PScrollBar );
procedure HandleEvent( var Event : TEvent ); virtual;
procedure Draw; virtual;
procedure Update;
private
exec : PExec_Context;
end;
{ TStackWindow }
PStackWindow = ^TStackWindow;
TStackWindow = object( TWindow )
V : PScrollBar;
S : PStackView;
constructor Init( var Bounds : TRect;
exec : PExec_Context );
end;
implementation
{$I DEBUGGER.INC}
{ TStackView }
constructor TStackView.Init;
begin
inherited Init( Bounds, 1, nil, AVScrollBar );
exec := aexec;
GrowMode := gfGrowHiX or gfGrowHiY;
DragMode := dmDragGrow or dmLimitLoX or dmLimitLoY;
EventMask := EventMask or evWave;
SetRange( exec^.stackSize );
end;
procedure TStackView.Draw;
const
Colors : array[0..1] of Byte = ($1E,$3E);
var
B : TDrawBuffer;
Color : Byte;
I, Item : Int;
S : String[16];
begin
Color := Colors[0];
if exec^.top <= Size.Y then Item := Size.Y-1
else Item := exec^.top-1-TopItem;
for I := 0 to Size.Y-1 do
begin
MoveChar( B, ' ', Color, Size.X );
if Item < exec^.top then
begin
S := ' ' + Hex16( Item ) + ': ' + Hex32( exec^.stack^[Item] );
MoveStr( B, S, Color );
end;
WriteLine( 0, I, Size.X, 1, B );
dec( Item );
end;
end;
procedure TStackView.Update;
begin
FocusItem( 0 );
DrawView;
end;
procedure TStackView.HandleEvent;
var
Limits : TRect;
Mini, Maxi : Objects.TPoint;
begin
case Event.What of
evWave : case Event.Command of
cmReFocus : Update;
end;
end;
inherited HandleEvent( Event );
case Event.Command of
cmResize: begin
Owner^.GetExtent(Limits);
SizeLimits( Mini, Maxi );
DragView(Event, DragMode, Limits, Mini, Maxi );
ClearEvent(Event);
end;
end;
end;
{ TStackWindow }
constructor TStackWindow.Init;
var
R : TRect;
begin
inherited Init( Bounds, 'Pile', wnNoNumber );
GetExtent( Bounds );
R := Bounds;
R.A.X := R.B.X-1;
inc( R.A.Y );
dec( R.B.Y );
New( V, Init(R) );
Insert( V );
R := Bounds;
R.Grow(-1,-1);
New( S, Init( R, exec, V ));
Insert( S );
end;
end.

196
pascal/test/statetv.pas Normal file
View File

@@ -0,0 +1,196 @@
unit StateTV;
interface
uses Objects, Views, Drivers, TTTypes, TTObjs, TTDebug;
{$I DEBUGGER.INC}
type
{ State Viewer }
{ A simple TView to show the current graphics state }
PStateViewer = ^TStateViewer;
TStateViewer = object( TView )
constructor Init( var Bounds : TRect;
aexec : PExec_Context );
procedure HandleEvent( var Event : TEvent ); virtual;
procedure Draw; virtual;
private
exec : PExec_Context;
end;
{ PStateWindow }
PStateWindow = ^TStateWindow;
TStateWindow = object( TWindow )
stateView : PStateViewer;
constructor Init( var Bounds : TRect;
exec : PExec_Context );
end;
implementation
{ TStateViewer }
constructor TStateViewer.Init;
begin
inherited Init( Bounds );
exec := aexec;
Options := Options or ofSelectable;
EventMask := EventMask or evWave;
end;
procedure TStateViewer.Draw;
var
B : TDrawBuffer;
S : String;
Color : Int;
n : Int;
begin
Color := $1E;
n := 0;
MoveChar( B, ' ', Color, Self.Size.X );
S := ' Loop ' + Hex16( exec^.GS.loop );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Auto_flip ';
if exec^.GS.auto_flip then S := S + ' Yes'
else S := S + ' No';
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Dual ('+Hex16(exec^.GS.dualVector.x)+','+
Hex16(exec^.GS.dualVector.y)+')';
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Projection ('+Hex16(exec^.GS.projVector.x)+','+
Hex16(exec^.GS.projVector.y)+')';
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Freedom ('+Hex16(exec^.GS.freeVector.x)+','+
Hex16(exec^.GS.freeVector.y)+')';
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Gep0 ' + Hex8( exec^.GS.gep0 );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Gep1 ' + Hex8( exec^.GS.gep1 );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Gep2 ' + Hex8( exec^.GS.gep2 );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Ins_Control ' + Hex8( exec^.GS.instruct_control );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Rounding ' + Hex8( exec^.GS.round_state );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Min_Distance ' + Hex32( exec^.GS.minimum_distance );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Rp0 ' + Hex8( exec^.GS.rp0 );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Rp1 ' + Hex8( exec^.GS.rp1 );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Rp2 ' + Hex8( exec^.GS.rp2 );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Ctrl_Val_Cutin ' + Hex32( exec^.GS.control_value_cutin );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Sngl_Width_Cutin ' + Hex32( exec^.GS.single_width_cutin );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Sngl_Widht_Value ' + Hex32( exec^.GS.single_width_value );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
S := ' Scan_type ' + Hex8( exec^.GS.scan_type );
MoveStr( B, S, Color );
WriteLine( 0, n, Self.Size.X, 1, B );
inc( n );
MoveChar( B, ' ', Color, Self.Size.X );
WriteLine( 0, n, Self.Size.X, Size.Y-n, B );
end;
procedure TStateViewer.HandleEvent;
var
Limits : TRect;
Mini, Maxi : Objects.TPoint;
begin
inherited HandleEvent( Event );
case Event.What of
evWave : case Event.Command of
cmReFocus : DrawView;
(*
cmResize: begin
Owner^.GetExtent(Limits);
SizeLimits( Mini, Maxi );
DragView(Event, DragMode, Limits, Mini, Maxi );
ClearEvent(Event);
end;
*)
end;
end;
end;
constructor TStateWindow.Init;
begin
inherited Init( Bounds, 'State', wnNoNumber );
GetExtent( Bounds );
Bounds.Grow(-1,-1);
New( StateView, Init( Bounds, exec ) );
Insert( StateView );
end;
end.

377
pascal/test/timer.pas Normal file
View File

@@ -0,0 +1,377 @@
{***************************************************************************}
{* *}
{* FreeType Performance Timer *}
{* *}
{* *}
{* This source code has been compiled and run under both Virtual Pascal *}
{* on OS/2 and Borland's BP7. *}
{* *}
{* *}
{* The C scan-line converter has been highly optimized, unlike the *}
{* Pascal one which is still 'aged'. Don't be surprised to see drastic *}
{* performance differences then.. *}
{* *}
{***************************************************************************}
program Timer;
uses
{$IFDEF OS2}
Use32,
{$ENDIF}
Crt,
Dos, (* for GetTime *)
GMain,
GEvents,
GDriver,
FreeType,
TTError, (* for CheckError *)
TTTypes; (* for commodity types *)
{$DEFINE VISUAL}
{ $DEFINE DEBUG}
{$IFDEF VISUAL}
{&PMTYPE NOVIO}
{$ENDIF}
const
Precis = 64;
Precis2 = Precis div 2;
PrecisAux = 1024;
Centre_X : int = 320;
Centre_Y : int = 225;
Max_Glyphs = 512;
var
xC : TT_PCoordinates;
yC : TT_PCoordinates;
Fl : TT_PTouchTable;
cons : PUShort;
outlines : array[0..Max_Glyphs-1] of TT_Outline;
lastp : int;
lastc : int;
res : int;
numPoints, numContours : int;
Bit : TT_Raster_Map;
Rotation : int; (* Angle modulo 1024 *)
num_glyphs : int;
gray_level : Boolean;
face : TT_Face;
instance : TT_Instance;
glyph : TT_Glyph;
metrics : TT_Glyph_Metrics;
imetrics : TT_Instance_Metrics;
props : TT_Face_Properties;
old_glyph : int;
cur_glyph : int;
tot_glyph : int;
grayLines : array[0..2048] of Byte;
error : TT_Error;
Procedure InitRows;
var
i: integer;
P: Pointer;
begin
if gray_level then
begin
Bit.rows := 200;
Bit.cols := 320;
Bit.width := 320*2;
Bit.flow := TT_Flow_Down;
Bit.size := 320*200;
end
else
begin
Bit.rows := 450;
Bit.cols := 80;
Bit.width := 640;
Bit.flow := TT_Flow_Down;
Bit.size := 80*450;
end;
GetMem( Bit.buffer, Bit.size );
if Bit.buffer = NIL then
begin
Writeln('ERREUR:InitRows:Not enough memory to allocate BitMap');
halt(1);
end;
FillChar( Bit.Buffer^, Bit.Size, 0 );
end;
Procedure ClearData;
var i: integer;
begin
FillChar( Bit.Buffer^, Bit.Size, 0 );
end;
procedure Preload_Glyphs( var start : Int );
var
i, j, fin, np, nc : integer;
outline : TT_Outline;
begin
fin := start + Max_Glyphs;
if fin > num_glyphs then fin := num_glyphs;
tot_glyph := fin-start;
cur_glyph := 0;
lastp := 0;
lastc := 0;
{$IFNDEF VISUAL}
Write('Loading ', fin-start,' glyphs ');
{$ENDIF}
for i := start to fin-1 do
begin
if TT_Load_Glyph( instance,
glyph,
i,
TT_Load_Default ) = TT_Err_Ok then
begin
TT_Get_Glyph_Outline( glyph, outline );
TT_New_Outline( outline.n_points,
outline.n_contours,
outlines[cur_glyph] );
outline.high_precision := false;
outline.second_pass := false;
TT_Copy_Outline( outline, outlines[cur_glyph] );
TT_Translate_Outline( outlines[cur_glyph],
vio_Width*16,
vio_Height*16 );
inc( cur_glyph );
end;
end;
start := fin;
end;
function ConvertRaster(index : integer) : boolean;
begin
if gray_level then
error := TT_Get_Outline_Pixmap( outlines[index], Bit )
else
error := TT_Get_Outline_Bitmap( outlines[index], Bit );
ConvertRaster := (error <> TT_Err_Ok);
end;
procedure Usage;
begin
Writeln('Simple TrueType Glyphs viewer - part of the FreeType project' );
Writeln;
Writeln('Usage : ',paramStr(0),' FontName[.TTF]');
Halt(1);
end;
function Get_Time : LongInt;
var
heure,
min,
sec,
cent :
{$IFDEF OS2}
longint;
{$ELSE}
word;
{$ENDIF}
begin
GetTime( heure, min, sec, cent );
Get_Time := 6000*longint(min) + 100*longint(sec) + cent;
end;
var i : integer;
Filename : String;
Fail : Int;
T, T0, T1 : Long;
start : Int;
begin
xC := NIL;
yC := NIL;
Fl := NIL;
TT_Init_FreeType;
if ParamCount = 0 then Usage;
gray_level := ParamStr(1)='-g';
if gray_level then
if ParamCount <> 2 then Usage else
else
if ParamCount <> 1 then Usage;
if gray_level then Filename := ParamStr(2)
else Filename := ParamStr(1);
if Pos('.',FileName) = 0 then FileName:=FileName+'.TTF';
error := TT_Open_Face( filename, face );
if error <> TT_Err_Ok then
begin
Writeln('ERROR: Could not open ', FileName );
Check_Error(error);
end;
TT_Get_Face_Properties( face, props );
num_glyphs := props.num_Glyphs;
i := length(FileName);
while (i > 1) and (FileName[i] <> '\') do dec(i);
FileName := Copy( FileName, i+1, length(FileName) );
error := TT_New_Glyph( face, glyph );
if error <> TT_Err_Ok then
begin
Writeln('ERROR : Could not get glyph' );
Check_Error(error);
end;
i := props.max_Points * num_glyphs;
GetMem( fl, i );
i := i * sizeof(Long);
GetMem( xC, i );
GetMem( yC, i );
i := props.max_Contours * num_glyphs;
GetMem( cons, i*sizeof(UShort) );
error := TT_New_Instance( face, instance );
if error <> TT_Err_Ok then
begin
Writeln('ERROR: Could not open face instance from ', Filename );
Check_Error(error);
end;
error := TT_Set_Instance_PointSize( instance, 400 );
if error <> TT_Err_Ok then
begin
Writeln('ERROR: Could set pointsize' );
Check_Error(error);
end;
Rotation := 0;
Fail := 0;
InitRows;
{$IFDEF VISUAL}
if gray_level then
begin
if not Set_Graph_Screen( Graphics_Mode_Gray ) then
Panic1( 'could not set grayscale graphics mode' );
end
else
begin
if not Set_Graph_Screen( Graphics_Mode_Mono ) then
Panic1( 'could not set mono graphics mode' );
end;
{$ENDIF}
start := 0;
T := Get_Time;
T1 := 0;
while start < num_glyphs do
begin
Preload_Glyphs(start);
{$IFNDEF VISUAL}
write('... ');
{$ENDIF}
T0 := Get_Time;
for cur_glyph := 0 to tot_glyph-1 do
begin
if not ConvertRaster(cur_glyph) then
{$IFDEF VISUAL}
begin
Display_Bitmap_On_Screen( Bit.Buffer^, Bit.rows, Bit.cols );
ClearData;
end
{$ELSE}
begin
end
{$ENDIF}
else
inc( Fail );
end;
T0 := Get_Time - T0;
writeln( T0/100:0:2,' s' );
inc( T1, T0 );
for cur_glyph := 0 to tot_glyph-1 do
TT_Done_Outline( outlines[cur_glyph] );
end;
T := Get_Time - T;
{$IFDEF VISUAL}
Restore_Screen;
{$ENDIF}
writeln;
writeln('Render time : ', T1/100:0:2,' s' );
writeln('Total time : ', T /100:0:2,' s');
writeln('Glyphs/second : ', Long(num_glyphs)*100/T1:0:1 );
writeln('Fails : ',Fail );
end.
begin
end.

523
pascal/test/view.pas Normal file
View File

@@ -0,0 +1,523 @@
{***************************************************************************}
{* *}
{* FreeType Glyph Viewer. *}
{* *}
{* *}
{* This small program will load a TrueType font file and allow *}
{* you to view/scale/rotate its glyphs. Glyphs are in the order *}
{* found within the 'glyf' table. *}
{* *}
{* NOTE : This version displays a magnified view of the glyph *}
{* along with the pixel grid. *}
{* *}
{* This source code has been compiled and run under both Virtual Pascal *}
{* on OS/2 and Borland's BP7. *}
{* *}
{***************************************************************************}
program View;
uses Crt,
Common,
{$IFDEF OS2}
Use32,
{$ENDIF}
GMain,
GEvents,
GDriver,
FreeType;
{&PMTYPE NOVIO}
{$DEFINE DEBUG}
const
Precis = 64;
Precis2 = Precis div 2;
PrecisAux = 1024;
Profile_Buff_Size = 32000;
Max_Files = 1024;
var
face : TT_Face;
instance : TT_Instance;
glyph : TT_Glyph;
metrics : TT_Glyph_Metrics;
imetrics : TT_Instance_Metrics;
props : TT_Face_Properties;
ymin, ymax, xmax, xmin, xsize : longint;
res, old_res : int;
numPoints, numContours : int;
Bit : TT_Raster_Map;
Rotation : int; (* Angle modulo 1024 *)
num_glyphs : int;
error : TT_Error;
gray_level : Boolean;
display_outline : boolean;
hint_glyph : boolean;
scan_type : Byte;
old_glyph : int;
cur_glyph : int;
scale_shift : Int;
grayLines : array[0..2048] of Byte;
(*******************************************************************
*
* Function : Set_Raster_Area
*
*****************************************************************)
procedure Set_Raster_Area;
begin
Bit.rows := vio_Height;
Bit.width := vio_Width;
Bit.flow := TT_Flow_Up;
if gray_level then
Bit.cols := Bit.width
else
Bit.cols := (Bit.width+7) div 8;
Bit.size := Bit.rows * Bit.cols;
end;
(*******************************************************************
*
* Function : Clear_Data
*
*****************************************************************)
procedure Clear_Data;
begin
if gray_level then
fillchar( Bit.buffer^, Bit.size, gray_palette[0] )
else
fillchar( Bit.buffer^, Bit.size, 0 );
end;
(*******************************************************************
*
* Function : Init_Engine
*
*****************************************************************)
procedure Init_Engine( maxRes : Int );
begin
Set_Raster_Area;
GetMem( Bit.buffer, Bit.size );
Clear_Data;
end;
(*******************************************************************
*
* Function : Reset_Scale
*
*****************************************************************)
function Reset_Scale( res : Int ) : Boolean;
begin
error := TT_Set_Instance_CharSize( instance, res*64 );
Reset_Scale := (error = TT_Err_Ok);
end;
(*******************************************************************
*
* Function : LoadTrueTypeChar
*
* Description : Loads a single glyph into the xcoord, ycoord and
* flag arrays, from the instance data.
*
*****************************************************************)
Function LoadTrueTypeChar( index : integer;
hint : boolean ) : TT_Error;
var
j, load_flag : int;
result : TT_Error;
begin
if hint then load_flag := TT_Load_Scale_Glyph or TT_Load_Hint_Glyph
else load_flag := TT_Load_Scale_Glyph;
result := TT_Load_Glyph( instance,
glyph,
index,
load_flag );
LoadTrueTypeChar := result;
end;
var
Error_String : String;
ine : Int;
function Render_ABC( glyph_index : integer ) : boolean;
var
i, j : integer;
x, y : longint;
start_x,
start_y,
step_x,
step_y : longint;
fail : Int;
begin
Render_ABC := True;
TT_Get_Instance_Metrics( instance, imetrics );
start_x := 4;
start_y := vio_Height - 30 - imetrics.y_ppem;
step_x := imetrics.x_ppem + 4;
step_y := imetrics.y_ppem + 10;
x := start_x;
y := start_y;
fail := 0;
ine := glyph_index;
while ine < num_glyphs do
begin
if LoadTrueTypeChar( ine, hint_glyph ) = TT_Err_Ok then
begin
TT_Get_Glyph_Metrics( glyph, metrics );
if gray_level then
TT_Get_Glyph_Pixmap( glyph, Bit, x*64, y*64 )
else
TT_Get_Glyph_Bitmap( glyph, Bit, x*64, y*64 );
inc( x, (metrics.advance div 64) + 1 );
if x > vio_Width - 40 then
begin
x := start_x;
dec( y, step_y );
if y < 10 then
begin
Render_ABC := False;
exit;
end;
end;
end
else
inc( fail );
inc(ine);
end;
Render_ABC := False;
end;
procedure Erreur( s : String );
begin
Restore_Screen;
Writeln( 'Error : ', s, ', error code = ', error );
Halt(1);
end;
procedure Usage;
begin
Writeln('Simple TrueType Glyphs viewer - part of the FreeType project' );
Writeln;
Writeln('Usage : ',paramStr(0),' FontName[.TTF]');
Halt(1);
end;
var
i: integer;
heure,
min1,
min2,
sec1,
sec2,
cent1,
cent2 :
{$IFDEF OS2}
longint;
{$ELSE}
word;
{$ENDIF}
C : Char;
Filename : String;
label Fin;
var
Fail : Int;
glyphStr : String[4];
ev : Event;
Code : Int;
init_memory, end_memory : LongInt;
num_args : Integer;
point_size : Integer;
cur_file : Integer;
first_arg : Int;
sortie : Boolean;
valid : Boolean;
errmsg : String;
label
Lopo;
begin
TextMode( co80+Font8x8 );
TT_Init_FreeType;
num_args := ParamCount;
if num_args = 0 then
Usage;
first_arg := 1;
gray_level := False;
if ParamStr(first_arg) = '-g' then
begin
inc( first_arg );
gray_level := True;
end;
if first_arg > num_args+1 then
Usage;
val( ParamStr(first_arg), point_size, Code );
if Code <> 0 then
point_size := 24
else
inc( first_arg );
Expand_Wildcards( first_arg, '.ttf' );
cur_file := 0;
if num_arguments = 0 then
begin
Writeln('Could not find file(s)');
Halt(3);
end;
if gray_level then
begin
if not Set_Graph_Screen( Graphics_Mode_Gray ) then
Erreur( 'could not set grayscale graphics mode' );
end
else
begin
if not Set_Graph_Screen( Graphics_Mode_Mono ) then
Erreur( 'could not set mono graphics mode' );
end;
Init_Engine( 24 );
repeat
valid := True;
FileName := arguments[cur_file]^;
if Pos('.',FileName) = 0 then FileName:=FileName+'.TTF';
error := TT_Open_Face( filename, face );
if error <> TT_Err_Ok then
begin
str( error, errmsg );
errmsg := 'Could not open '+filename+', error code = '+errmsg;
valid := false;
goto Lopo;
end;
TT_Get_Face_Properties( face, props );
num_glyphs := props.num_Glyphs;
i := length(FileName);
while (i > 1) and (FileName[i] <> '\') do dec(i);
FileName := Copy( FileName, i+1, length(FileName) );
error := TT_New_Glyph( face, glyph );
if error <> TT_Err_Ok then
Erreur('Could not create glyph container');
error := TT_New_Instance( face, instance );
if error <> TT_Err_Ok then
begin
str( error, errmsg );
errmsg := 'Could not create instance, error code = '+errmsg;
valid := false;
goto Lopo;
end;
TT_Set_Instance_Resolutions( instance, 96, 96 );
Rotation := 0;
Fail := 0;
res := point_size;
scan_type := 2;
Reset_Scale( res );
Lopo:
display_outline := true;
hint_glyph := true;
old_glyph := -1;
old_res := res;
cur_glyph := 0;
sortie := false;
Repeat
if valid then
begin
if Render_ABC( cur_glyph ) then
inc( Fail )
else
Display_Bitmap_On_Screen( Bit.Buffer^, Bit.rows, Bit.cols );
Clear_Data;
Print_XY( 0, 0, FileName );
TT_Get_Instance_Metrics( instance, imetrics );
Print_Str(' pt size = ');
Str( imetrics.pointSize div 64:3, glyphStr );
Print_Str( glyphStr );
Print_Str(' ppem = ');
Str( imetrics.y_ppem:3, glyphStr );
Print_Str( glyphStr );
Print_Str(' glyph = ');
Str( cur_glyph, glyphStr );
Print_Str( glyphStr );
Print_XY( 0, 1, 'Hinting (''z'') : ' );
if hint_glyph then Print_Str('on ')
else Print_Str('off');
Print_XY( 0, 2, 'scan type(''e'') : ' );
case scan_type of
0 : Print_Str('none ');
1 : Print_Str('level 1');
2 : Print_Str('level 2');
4 : Print_Str('level 4');
5 : Print_Str('level 5');
end;
end
else
begin
Clear_Data;
Display_Bitmap_On_Screen( Bit.buffer^, Bit.rows, Bit.cols );
Print_XY( 0, 0, errmsg );
end;
Get_Event(ev);
case ev.what of
event_Quit : goto Fin;
event_Keyboard : case char(ev.info) of
'n' : begin
sortie := true;
if cur_file+1 < num_arguments then
inc( cur_file );
end;
'p' : begin
sortie := true;
if cur_file > 0 then
dec( cur_file );
end;
'z' : hint_glyph := not hint_glyph;
'e' : begin
inc( scan_type );
if scan_type = 3 then scan_type := 4;
if scan_type >= 6 then scan_type := 0;
end;
end;
event_Scale_Glyph : begin
inc( res, ev.info );
if res < 1 then res := 1;
if res > 1400 then res := 1400;
end;
event_Change_Glyph : begin
inc( cur_glyph, ev.info );
if cur_glyph < 0 then cur_glyph := 0;
if cur_glyph >= num_glyphs
then cur_glyph := num_glyphs-1;
end;
end;
if res <> old_res then
begin
if not Reset_Scale(res) then
Erreur( 'Could not resize font' );
old_res := res;
end;
Until sortie;
TT_Done_Glyph( glyph );
TT_Close_Face( face );
until false;
Fin:
Restore_Screen;
Writeln;
Writeln('Fails : ', Fail );
TT_Done_FreeType;
end.

222
pascal/test/zonetv.pas Normal file
View File

@@ -0,0 +1,222 @@
{****************************************************************************}
{* *}
{* ZoneTV.PAS *}
{* *}
{* This unit implements a simple TrueType zone points viewer for the *}
{* FREETYPE project debugger. *}
{* *}
{****************************************************************************}
Unit ZoneTV;
interface
uses Objects, Views, Drivers, FreeType, TTTypes, TTTables, TTObjs, TTDebug;
{$I DEBUGGER.INC}
type
{ TZoneViewer }
{ This TView is a simple point array viewer }
PZoneViewer = ^TZoneViewer;
TZoneViewer = object( TListViewer )
constructor Init( var Bounds : TRect;
AZone : PGlyph_Zone );
procedure Draw; virtual;
procedure HandleEvent( var Event : TEvent ); virtual;
private
Zone : PGlyph_Zone; { Pointer to the zone being displayed }
Save : TGlyph_Zone; { A copy of the zone to highlight }
{ changes }
procedure Copy_Zone;
end;
{ TCodeWindow }
PZoneWindow = ^TZoneWindow;
TZoneWindow = object( TWindow )
ZoneView : PZoneViewer;
constructor Init( var Bounds : TRect;
AZone : PGlyph_Zone );
end;
implementation
{ TZoneViewer }
constructor TZoneViewer.Init;
var
n : Int;
begin
inherited Init( Bounds, 1, nil, nil );
GrowMode := gfGrowHiX or gfGrowHiY;
DragMode := dmDragGrow or dmLimitLoX or dmLimitLoY;
Options := Options or ofSelectable;
EventMask := EventMask or evWave;
Zone := AZone;
GetMem( Save.org, zone^.n_points*2*sizeof(Long) );
GetMem( Save.cur, zone^.n_points*2*sizeof(Long) );
GetMem( Save.flags, zone^.n_points*sizeof(Byte) );
Save.n_points := Zone^.n_points;
Save.n_contours := Zone^.n_contours;
Copy_Zone;
SetRange( Save.n_points );
end;
procedure TZoneViewer.Copy_Zone;
var
n : Int;
begin
n := 2*zone^.n_points * sizeof(Long);
(* Note that we save also the original coordinates, as we're not sure *)
(* that the debugger is debugged ! *)
move( Zone^.org^, Save.org^, n );
move( Zone^.cur^, Save.cur^, n );
move( Zone^.flags^, Save.flags^, zone^.n_points );
end;
procedure TZoneViewer.HandleEvent( var Event : TEvent );
var
Limits : TRect;
Mini, Maxi : Objects.TPoint;
begin
inherited HandleEvent(Event);
Case Event.What of
evWave : case Event.Command of
cmNewExecution : Copy_Zone;
cmRefocus : DrawView;
end;
evCommand : case Event.Command of
cmResize: begin
Owner^.GetExtent(Limits);
SizeLimits( Mini, Maxi );
DragView(Event, DragMode, Limits, Mini, Maxi );
ClearEvent(Event);
end;
end;
end;
end;
procedure TZoneViewer.Draw;
const
Colors : array[0..3] of byte
= ($30,$3F,$0B,$0E);
Touchs : array[0..3] of Char
= (' ','x','y','b');
OnOff : array[0..1] of Char
= (' ',':');
var
I, J, Item : Int;
B : TDrawBuffer;
S : String;
Indent : Int;
Ligne : Int;
Changed : Boolean;
Back_Color,
Color : word;
On_BP : boolean;
BP : PBreakPoint;
begin
if HScrollBar <> nil then Indent := HScrollBar^.Value
else Indent := 0;
with Save do
begin
for I := 0 to Self.Size.Y-1 do
begin
MoveChar( B, ' ', Colors[0], Self.Size.X );
Item := TopItem + I;
if (Range > 0) and
( Focused = Item ) then Back_Color := 2
else Back_Color := 0;
if Item < n_points then
begin
Color := Back_Color;
if ( flags^[item] <> Zone^.flags^[item] ) then inc( Color );
S := Hex16( Item ) + ': ';
S[1] := OnOff[Zone^.flags^[item] and 1];
S[7] := Touchs[(Zone^.flags^[item] and TT_Flag_Touched_Both) shr 1];
MoveStr( B, S, Colors[Color] );
Color := Back_Color;
if ( org^[item].x <> Zone^.org^[item].x ) then inc( Color );
MoveStr ( B[8], Hex32( Zone^.org^[item].x ), Colors[Color] );
MoveChar( B[16], ',', Colors[0], 1 );
Color := Back_Color;
if ( org^[item].y <> Zone^.org^[item].y ) then inc( Color );
MoveStr( B[17], Hex32( Zone^.org^[item].y ), Colors[Color] );
MoveStr( B[25], ' : ', Colors[0] );
Color := Back_Color;
if ( cur^[item].x <> Zone^.cur^[item].x ) then inc( Color );
MoveStr ( B[28], Hex32( Zone^.cur^[item].x ), Colors[Color] );
MoveChar( B[36], ',', Colors[0], 1 );
Color := Back_Color;
if ( cur^[item].y <> Zone^.cur^[item].y ) then inc( Color );
MoveStr( B[37], Hex32( Zone^.cur^[item].y ), Colors[Color] );
end;
WriteLine( 0, I, Self.Size.X, 1, B );
end;
end;
end;
{ TZoneWindow }
constructor TZoneWindow.Init;
begin
inherited Init( Bounds,'Zone',wnNoNumber );
GetExtent( Bounds );
Bounds.Grow(-1,-1);
New( ZoneView, Init( Bounds, AZone ) );
Insert( ZoneView );
end;
end.