pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

freetype1 Pascal version, initial checkin from http://cvsweb.xfree86.org/cvsweb/xc/extras/FreeType/pascal/lib/Attic/

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1565 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
sekelsenmat
2011-04-12 08:50:13 +00:00
parent b47cb1562e
commit 0ca7bd6a4a
20 changed files with 19227 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1931
components/freetypepascal/freetype.pas Normal file
View File

File diff suppressed because it is too large Load Diff

433
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/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
components/freetypepascal/ttgload.pas Normal file
View File

File diff suppressed because it is too large Load Diff

4797
components/freetypepascal/ttinterp.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1496
components/freetypepascal/ttload.pas Normal file
View File

File diff suppressed because it is too large Load Diff

282
components/freetypepascal/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
components/freetypepascal/ttobjs.pas Normal file
View File

File diff suppressed because it is too large Load Diff

3445
components/freetypepascal/ttraster.pas Normal file
View File

File diff suppressed because it is too large Load Diff

247
components/freetypepascal/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
components/freetypepascal/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.