paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 20:18:11 +02:00
Code Issues Packages Projects Releases Wiki Activity
main
lazarus/components/freetype/ttobjs.pas
mattias 733ac0edd1 freetype: cleaned up some uses sections
2024-03-20 15:42:59 +01:00

1944 lines
61 KiB
ObjectPascal
Raw Permalink Blame History

(*******************************************************************
*
* ttobjs.pas 2.0
*
* Objects definition 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.
*
******************************************************************)
(* *)
(* The four important objects managed by the library are : *)
(* *)
(* Face : the object for a given typeface *)
(* Instance : the object for a face's given pointsize/transform *)
(* Context : the object for a given glyph loading/hinting execution *)
(* Glyph : the object for a given glyph ( outline and metrics ) *)
(* *)
(* A Face object is described by a TFace record, and its *)
(* associated sub-tables. It is created through a call to the *)
(* 'TT_Open_Face' API. *)
(* *)
(* An Instance object is described by a TInstance record, and *)
(* sub-tables. It is created for a given face through a call to the *)
(* 'TT_Open_Instance' API. Several instances can share the same face *)
(* *)
(* The pointsize and/or transform of a given instance object can be *)
(* changed on the fly through a call to the 'TT_Reset_Instance' API. *)
(* *)
(* A Glyph object is used to describe a glyph to the client application *)
(* It is made of a TGlyph_Record header, with several sub-tables used *)
(* to store, for example, point coordinates or outline info.. *)
(* It can hold metrics information and other attributes, as well as *)
(* the glyph's outline. A client application can request any kind of *)
(* info to the library on a given glyph through the 'TT_Get_Glyph' *)
(* call. *)
(* *)
(* *)
(* A Context is described by a TExec_Context record, and sub-tables *)
(* Execution contexts are created on demand during the following *)
(* operations : *)
(* *)
(* - creating a new instance ( to read and execute the font program ) *)
(* - setting/resetting the pointsize ( to execute the CVT program ) *)
(* - during glyph loading ( when hinting is on ) *)
(* *)
(* They are used to run TrueType instructions and load/store *)
(* glyph data that are not part of the Glyph object ( as they're of *)
(* no meaning to a client application ). *)
(* *)
(* The library keeps track of all objects related to a given face : *)
(* *)
(* A face's instances are kept in two linked lists : one is the 'active' *)
(* list, which tracks the face's current opened instances, while the *)
(* other is the 'idle' list used to collect/recycle instance objects *)
(* when they become unuseful after a 'TT_Close_Instance' call. *)
(* *)
(* In the same way, a face's execution contexts are kept in two *)
(* similar lists. Note that, as contexts are created on demand, *)
(* the active and idle contexts lists should always contain few *)
(* elements. *)
(* *)
(* Look also for the following files : *)
(* *)
(* Face manager : TTFace.pas *)
(* Instance manager : TTInst.pas *)
(* Context manager : TTExec.pas *)
(* Glyph manager : TTGlyph.pas *)
(* *)
unit TTObjs;
interface
{$mode Delphi}
{$I TTCONFIG.INC}
{$R-}
uses LazFreeType,
TTTypes,
TTCalc,
TTError,
TTMemory,
TTCache,
TTFile,
TTTables,
TTCMap;
type
(* Graphics State *)
(* *)
(* The Graphics State (GS) is managed by the *)
(* instruction field, but does not come from *)
(* the font file. Thus, we can use 'int's *)
(* where needed. *)
(* *)
PGraphicsState = ^TGraphicsState;
TGraphicsState = record
rp0,
rp1,
rp2 : int;
dualVector,
projVector,
freeVector : TT_UnitVector;
loop : longint;
minimum_distance : TT_F26dot6;
round_state : int;
auto_flip : boolean;
control_value_cutin : TT_F26dot6;
single_width_cutin : TT_F26dot6;
single_width_value : TT_F26dot6;
delta_base : int;
delta_shift : int;
instruct_control : byte;
scan_control : Boolean;
scan_type : Int;
gep0,
gep1,
gep2 : int;
end;
const
Default_GraphicsState : TGraphicsState
= (
rp0 : 0;
rp1 : 0;
rp2 : 0;
dualVector : ( x:$4000; y:0 );
projVector : ( x:$4000; y:0 );
freeVector : ( x:$4000; y:0 );
loop : 1;
minimum_distance : 64;
round_state : 1;
auto_flip : True;
control_value_cutin : 4*17;
single_width_cutin : 0;
single_width_value : 0;
delta_Base : 9;
delta_Shift : 3;
instruct_control : 0;
scan_control : True;
scan_type : 0;
gep0 : 1;
gep1 : 1;
gep2 : 1
);
(**********************************************************************)
(* *)
(* Execution Subtables : *)
(* *)
(**********************************************************************)
const
MaxCodeRanges = 3;
(* There can only be 3 active code ranges at once : *)
(* - the Font Program *)
(* - the CVT Program *)
(* - a glyph's instructions set *)
TT_CodeRange_Font = 1;
TT_CodeRange_Cvt = 2;
TT_CodeRange_Glyph = 3;
CvtFlag_None = 0;
CvtFlag_X = 1;
CvtFlag_Y = 2;
CvtFlag_Both = 3;
type
TCodeRange = record
Base : PByte;
Size : Int;
end;
PCodeRange = ^TCodeRange;
(* defines a code range *)
(* *)
(* code ranges can be resident to a glyph ( i.e. the Font Program) *)
(* while some others are volatile ( Glyph instructions ) *)
(* tracking the state and presence of code ranges allows function *)
(* and instruction definitions within a code range to be forgotten *)
(* when the range is discarded *)
TCodeRangeTable = array[1..MaxCodeRanges] of TCodeRange;
(* defines a function/instruction definition record *)
PDefRecord = ^TDefRecord;
TDefRecord = record
Range : Int; (* in which code range is it located ? *)
Start : Int; (* where does it start ? *)
Opc : Byte; (* function #, or instruction code *)
Active : boolean; (* is the entry active ? *)
end;
PDefArray = ^TDefArray;
TDefArray = array[0..99] of TDefRecord;
(* defines a call record, used to manage function calls *)
TCallRecord = record
Caller_Range : Int;
Caller_IP : Int;
Cur_Count : Int;
Cur_Restart : Int;
end;
(* defines a simple call stack *)
TCallStack = array[0..99] of TCallRecord;
PCallStack = ^TCallStack;
PGlyph_Zone = ^TGlyph_Zone;
TGlyph_Zone = record
n_points : Int;
n_contours : Int;
org : TT_Points; (* original (scaled) coords *)
cur : TT_Points; (* current coordinates *)
flags : TT_PTouchTable;
conEnds : PUShort;
end;
TRound_Function = function( distance, compensation : TT_F26dot6 )
: TT_F26dot6 of object;
(* Rounding function, as used by the interpreter *)
TMove_Function = procedure( zone : PGlyph_Zone;
point : Int;
distance : TT_F26dot6 ) of object;
(* Point displacement along the freedom vector routine, as *)
(* used by the interpreter *)
TProject_Function = function( var P1, P2 : TT_Vector ) : TT_F26dot6 of object;
(* Distance projection along one of the proj. vectors, as used *)
(* by the interpreter *)
TFunc_Get_CVT = function ( index : Int ) : TT_F26Dot6 of object;
(* Reading a cvt value. Take care of non-square pixels when *)
(* needed *)
TFunc_Set_CVT = procedure( index : Int; value : TT_F26Dot6 ) of object;
(* Setting or Moving a cvt value. Take care of non-square *)
(* pixels when needed *)
(********************************************************************)
(* *)
(* Glyph Sub-Tables *)
(* *)
(********************************************************************)
PGlyph_Transform = ^TGlyph_Transform;
TGlyph_Transform = record
xx, xy : TT_Fixed;
yx, yy : TT_Fixed;
ox, oy : TT_F26Dot6;
end;
PSubglyph_Record = ^TSubglyph_Record;
TSubglyph_Record = record
index : Int;
is_scaled : boolean;
is_hinted : boolean;
preserve_pps : boolean;
bbox : TT_BBox;
zone : TGlyph_Zone;
arg1, arg2 : Int;
element_flag : Int;
transform : TGlyph_Transform;
file_offset : Long;
pp1, pp2 : TT_Vector;
advanceWidth : Int;
leftBearing : Int;
end;
TSubglyph_Stack = array[0..10] of TSubglyph_Record;
PSubglyph_Stack = ^TSubglyph_Stack;
(* A note regarding non-squared pixels : *)
(* *)
(* ( This text will probably go into some docs at some time, for *)
(* now, it is kept there to explain some definitions in the *)
(* TIns_Metrics record ). *)
(* *)
(* The CVT is a one-dimensional array containing values that *)
(* control certain important characteristics in a font, like *)
(* the height of all capitals, all lowercase letter, default *)
(* spacing or stem width/height. *)
(* *)
(* These values are found in FUnits in the font file, and must be *)
(* scaled to pixel coordinates before being used by the CVT and *)
(* glyph programs. Unfortunately, when using distinct x and y *)
(* resolutions ( or distinct x and y pointsizes ), there are two *)
(* possible scalings. *)
(* *)
(* A first try was to implement a 'lazy' scheme were all values *)
(* were scaled when first used. However, some values are always *)
(* used in the same direction, and some other are used in many *)
(* different circumstances and orientations. *)
(* *)
(* I have found a simpler way to do the same, and it even seems to *)
(* work in most of the cases : *)
(* *)
(* - all CVT values are scaled to the maximum ppem size *)
(* *)
(* - when performing a read or write in the CVT, a ratio factor *)
(* is used to perform adequate scaling. Example : *)
(* *)
(* x_ppem = 14 *)
(* y_ppem = 10 *)
(* *)
(* we chose ppem = x_ppem = 14 as the CVT scaling size. All cvt *)
(* entries are scaled to it. *)
(* *)
(* x_ratio = 1.0 *)
(* y_ratio = y_ppem/ppem ( < 1.0 ) *)
(* *)
(* we compute the current ratio like : *)
(* *)
(* - if projVector is horizontal, ratio = x_ratio = 1.0 *)
(* - if projVector is vertical, ratop = y_ratio *)
(* - else, ratio = sqrt( (proj.x*x_ratio)**2+(proj.y*y_ratio)**2 ) *)
(* *)
(* reading a cvt value returns ratio*cvt[index] *)
(* writing a cvt value in pixels cvt[index]/ratio *)
(* *)
(* the current ppem is simple ratio*ppem *)
(* *)
TIns_Metrics = record
pointsize : TT_F26Dot6;
x_resolution : Int;
y_resolution : Int;
x_ppem : Int;
y_ppem : Int;
x_scale1 : Long;
x_scale2 : Long;
y_scale1 : Long;
y_scale2 : Long;
(* for non-square pixels *)
x_ratio : Long;
y_ratio : Long;
scale1 : Long;
scale2 : Long;
ppem : Int;
ratio : Long;
(* compensations *)
compensations : array[0..3] of TT_F26Dot6;
(* flags *)
rotated : Boolean;
stretched : Boolean;
end;
(********************************************************************)
(* *)
(* FreeType Face Object *)
(* *)
(********************************************************************)
PFace = ^TFace;
PInstance = ^TInstance;
PExec_Context = ^TExec_Context;
TFace = record
stream : TT_Stream;
(* i/o stream *)
ttcHeader : TTTCHeader;
(* TrueType collection header, if any was found *)
maxProfile : TMaxProfile;
(* maximum profile table, as defined by the TT Spec *)
(* Note : *)
(* it seems that some maximum values cannot be *)
(* taken directly from this table, but rather by *)
(* combining some of its fields ( e.g. the max. *)
(* number of points seems to be given by *)
(* MAX( maxPoints, maxCompositePoints ) *)
(* *)
(* For this reason, we define later our own *)
(* max values that are used to load and allocate *)
(* further tables.. *)
fontHeader : TT_Header;
(* the font header as defined by the TT Spec *)
horizontalHeader : TT_Horizontal_Header;
(* the horizontal header, as defined in the spec *)
verticalInfo : Boolean;
(* set to true when vertical data is in the font *)
verticalHeader : TT_Vertical_Header;
(* vertical header table *)
os2 : TT_OS2;
(* 'OS/2' table *)
postscript : TT_Postscript;
(* 'Post' table *)
hdmx : THdmx;
(* 'hdmx' = horizontal device metrics table *)
nameTable : TName_Table;
(* 'name' = name table *)
numTables : Int;
dirTables : PTableDirEntries;
(* The directory of the TrueType tables found in *)
(* this face's stream *)
numCMaps : Int;
cMaps : PCMapTables;
(* the directory of character mappings tables found *)
(* for this face.. *)
numLocations : Int;
glyphLocations : PStorage;
(* the glyph locations table *)
(* the hmtx table is now within the horizontal header *)
fontPgmSize : Int;
fontProgram : PByte;
(* the font program, if any.. *)
cvtPgmSize : Int;
cvtProgram : PByte;
(* the cvt (or 'prep') program, if any.. *)
cvtSize : Int;
cvt : PShort;
(* the original, unscaled, control value table *)
gasp : TGasp;
(* the following values must be set by the *)
(* maximum profile loader.. *)
numGlyphs : Int;
(* the face's total number of glyphs *)
maxPoints : Int;
(* max glyph points number, simple and composite *)
maxContours : Int;
(* max glyph contours number, simple and composite *)
maxComponents : Int;
(* max components in a composite glyph *)
(* the following lists are used to track active *)
(* instance and context objects, as well as *)
(* to recycle them.. *)
(* see 'TTLists'.. *)
instances : TCache;
glyphs : TCache;
kernings : TObject;
(* various caches for this face's child objects *)
extension : Pointer;
(* a typeless pointer to the face object's extensions *)
genericP : Pointer;
(* generic pointer - see TT_Set/Get_Face_Pointer *)
end;
(********************************************************************)
(* *)
(* FreeType Instance Object *)
(* *)
(********************************************************************)
TInstance = record
owner : PFace;
valid : Boolean;
metrics : TIns_Metrics;
numFDefs : Int; (* number of function defs *)
maxFDefs : Int;
FDefs : PDefArray; (* table of FDefs entries *)
numIDefs : Int; (* number of instruction defs *)
maxIDefs : Int;
IDefs : PDefArray; (* table of IDefs entries *)
maxFunc : Int; (* maximum function number *)
maxIns : Int; (* maximum instruction number *)
codeRangeTable : TCodeRangeTable;
GS : TGraphicsState;
storeSize : Int;
storage : PStorage;
(* the storage area *)
cvtSize : Int;
cvt : PLong;
(* the scaled control value table *)
twilight : TGlyph_Zone;
(* the instance's twilight zone *)
(* debugging variables *)
debug : Boolean;
context : PExec_Context;
(* when using the debugger, we must keep the *)
(* execution context with the instance object *)
(* rather than asking it on demand *)
genericP: Pointer;
(* generic pointer - see TT_Set/Get_Instance_Pointer *)
end;
(********************************************************************)
(* *)
(* FreeType Execution Context Object *)
(* *)
(********************************************************************)
TExec_Context = record
face : PFace;
instance : PInstance;
error : Int;
interpreter: TObject;
stackSize : Int; (* size of instance stack *)
stack : PStorage; (* current instance stack *)
zp0,
zp1,
zp2,
twilight,
pts : TGlyph_Zone;
GS : TGraphicsState;
curRange : Int; (* current code range number *)
code : PByte; (* current code range *)
IP : Int; (* current instruction pointer *)
codeSize : Int; (* size of current range *)
step_ins : boolean; (* used by the interpreter *)
(* if true, go to the next *)
(* instruction.. *)
loadSize : Int;
loadStack : PSubglyph_Stack;
(* the load stack used to load composite glyphs *)
glyphIns : PByte; (* glyph instructions *)
glyphSize : Int; (* glyph ins. size *)
callSize : Int;
callStack : PCallStack; (* interpreter call stack *)
period, (* values used for the *)
phase, (* 'SuperRounding' *)
threshold : TT_F26dot6;
maxPoints : Int;
maxContours : Int;
(* the following are copies of the variables found *)
(* in an instance object *)
numFDefs : Int; (* number of function defs *)
maxFDefs : Int;
FDefs : PDefArray; (* table of FDefs entries *)
numIDefs : Int; (* number of instruction defs *)
maxIDefs : Int;
IDefs : PDefArray; (* table of IDefs entries *)
maxFunc : Int; (* maximum function number *)
maxIns : Int; (* maximum instruction number *)
codeRangeTable : TCodeRangeTable;
storeSize : Int; (* size of current storage *)
storage : PStorage; (* storage area *)
metrics : TIns_Metrics;
cur_ppem : Int;
scale1 : Long;
scale2 : Long;
cached_metrics : Boolean;
(*
numContours : Int;
endContours : PUShort;
*)
Instruction_Trap : Boolean;
(* used by the full-screen debugger. If set, the *)
(* interpreter will exit after executing one *)
(* opcode. Used to perform single-stepping.. *)
is_composite : Boolean;
(* this flag is true when the glyph is a composite *)
(* one. In this case, we measure original distances *)
(* in the loaded coordinates (font units), then *)
(* scale them appropriately. This get rids of *)
(* transformation artifacts (like symetries..) *)
cvtSize : Int;
cvt : PLong;
(* these variables are proper to the context *)
F_dot_P : Long;
(* the dot product of the free and projection *)
(* vector is used in frequent operations.. *)
func_round : TRound_Function;
func_project : TProject_Function;
func_dualproj : TProject_Function;
func_freeProj : TProject_Function;
func_move : TMove_Function;
func_read_cvt : TFunc_Get_CVT;
func_write_cvt : TFunc_Set_CVT;
func_move_cvt : TFunc_Set_CVT;
(* single width ? *)
end;
(********************************************************************)
(* *)
(* FreeType Glyph Object *)
(* *)
(********************************************************************)
PGlyph = ^TGlyph;
TGlyph = record
face : PFace;
metrics : TT_Big_Glyph_Metrics;
outline : TT_Outline;
(* temporary - debugging purposes *)
computed_width : Int;
precalc_width : Int;
is_composite : Boolean;
end;
PFont_Input = ^TFont_Input;
TFont_Input = record
stream : TT_Stream; (* input stream *)
fontIndex : Int; (* index of font in collection *)
end;
(****************************************************************)
(* *)
(* Code Range Functions *)
(* *)
(****************************************************************)
function Goto_CodeRange( exec : PExec_Context;
range : Int;
IP : Int ) : TError;
(* Go to a specified coderange *)
function Get_CodeRange( exec : PExec_Context;
range : Int ) : PCodeRange;
(* return a pointer to a given coderange record *)
(* used only by the debugger *)
function Set_CodeRange( exec : PExec_Context;
range : Int;
base : Pointer;
length : Int ) : TError;
(* Set a given code range properties *)
function Clear_CodeRange( exec : PExec_Context;
range : Int ) : TError;
(* Clear a given code range *)
(****************************************************************)
(* *)
(* Management Functions *)
(* *)
(****************************************************************)
function New_Context( instance : PInstance ) : PExec_Context;
(* Get a new execution context, either fresh or recycled, for *)
(* an instance of the face 'res' *)
(* *)
(* Notes : - called by 'New_Face_Context' *)
(* - assumes that the face mutex is acquired *)
procedure Done_Context( exec : PExec_Context );
(* Releases an execution context. The context can be destroyed *)
(* or recycled, depending on implementation *)
(* *)
(* Notes : - called by 'Done_Face_Context' *)
(* - assumes that the face mutex is acquired *)
(****************************************************************)
(* *)
(* Instance Update Functions *)
(* *)
(****************************************************************)
procedure Context_Load( exec : PExec_Context;
ins : PInstance );
(* update exec's data with the one found in 'ins' *)
(* typically before an execution *)
procedure Context_Save( exec : PExec_Context;
ins : PInstance );
(* update ins's data with the one found in 'exec' *)
(* typically after an execution *)
function Context_Run( exec : PExec_Context;
debug : Boolean ) : TError;
function Instance_Init( ins : PInstance ) : TError;
function Instance_Reset( ins : PInstance;
debug : boolean ) : TError;
function Scale_X( var metrics : TIns_Metrics; x : TT_Pos ) : TT_Pos;
function Scale_Y( var metrics : TIns_Metrics; y : TT_Pos ) : TT_Pos;
function TTObjs_Init : TError;
(* Initialize object manager *)
procedure TTObjs_Done;
(* Finalize object manager *)
var
face_cache : TCache;
exec_cache : TCache;
implementation
uses TTLoad, TTInterp;
function Face_Create( _face : Pointer;
_input : Pointer ) : TError; forward;
function Face_Destroy( _face : Pointer ) : TError; forward;
function Context_Create( _context : Pointer;
_face : Pointer ) : TError; forward;
function Context_Destroy( exec : Pointer ) : TError; forward;
function Instance_Create( _ins : Pointer;
_face : Pointer ) : TError; forward;
function Instance_Destroy( instance : Pointer ) : TError; forward;
function Glyph_Create( _glyph : Pointer;
_face : Pointer ) : TError; forward;
function Glyph_Destroy( _glyph : Pointer ) : TError; forward;
const
objs_face_class : TCache_Class
= (object_size: sizeof(TFace);
idle_limit : -1;
init : Face_Create;
done : Face_Destroy );
objs_exec_class : TCache_Class
= (object_size: sizeof(TExec_Context);
idle_limit : 1;
init : Context_Create;
done : Context_Destroy );
objs_instance_class : TCache_Class
= (object_size: sizeof(TInstance);
idle_limit : -1;
init : Instance_Create;
done : Instance_Destroy );
objs_glyph_class : TCache_Class
= (object_size: sizeof(TGlyph);
idle_limit : -1;
init : Glyph_Create;
done : Glyph_Destroy );
(*******************************************************************
*
* Function : New_Context
*
* Description : gets a new active execution context for a given
* resident/face object.
*
* Input : aResident
*
* Output : Returns new exec. context. Nil in case of failure
*
* Notes : Don't forget to modify 'Free_Context' if you change
* the fields of a TExec_Context
*
******************************************************************)
function New_Context( instance : PInstance ) : PExec_Context;
var
exec : PExec_Context;
begin
if instance = nil then
exec := nil
else
Cache_New( exec_cache, Pointer(exec), instance^.owner );
New_Context := exec;
end;
(*******************************************************************
*
* Function : Done_Context
*
* Description :
*
* Input : aResident
*
* Output : Discards an active execution context when it
* becomes unuseful. It is putin its face's recycle
* list
*
******************************************************************)
procedure Done_Context( exec : PExec_Context );
begin
if exec <> nil then
Cache_Done( exec_cache, Pointer(exec) );
end;
(*******************************************************************
*
* Function : New_Instance
*
* Description : gets a new active instance for a given
* face object.
*
* Input : face
*
* Output : Returns new instance. Nil in case of failure
*
******************************************************************)
function New_Instance( face : PFace ) : PInstance;
var
ins : PInstance;
begin
if face = nil then
ins := nil
else
Cache_New( face^.instances, Pointer(ins), face );
New_Instance := ins;
end;
(*******************************************************************
*
* Function : Done_Instance
*
* Description :
*
* Input : instance
*
* Output : Discards an active instance when it
* becomes unuseful. It is put in its face's recycle
* list
*
******************************************************************)
procedure Done_Instance( instance : PInstance );
begin
if instance <> nil then
Cache_Done( instance^.owner^.instances, Pointer(instance) );
end;
(****************************************************************)
(* *)
(* Code Range Functions *)
(* *)
(****************************************************************)
(*******************************************************************
*
* Function : Goto_CodeRange
*
* Description : Switch to a new code range (updates Code and IP).
*
* Input : exec target execution context
* range new execution code range
* IP new IP in new code range
*
* Output : SUCCESS on success. FAILURE on error (no code range).
*
*****************************************************************)
function Goto_CodeRange( exec : PExec_Context;
range : Int;
IP : Int ) : TError;
begin
Goto_CodeRange := Failure;
if (range < 1) or (range > 3) then
begin
error := TT_Err_Bad_Argument;
exit;
end;
with exec^.codeRangeTable[range] do
begin
if base = nil then
begin
error := TT_Err_Invalid_CodeRange;
exit;
end;
(* NOTE : Because the last instruction of a program may be a CALL *)
(* which will return to the first byte *after* the code *)
(* range, we test for IP <= Size, instead of IP < Size. *)
if IP > size then
begin
error := TT_Err_Code_Overflow;
exit;
end;
exec^.code := base;
exec^.codeSize := size;
exec^.IP := IP;
exec^.currange := range;
end;
Goto_CodeRange := Success;
end;
(*******************************************************************
*
* Function : Get_CodeRange
*
* Description : Returns a pointer to a given code range. Should
* be used only by the debugger. Returns NULL if
* 'range' is out of current bounds.
*
* Input : exec target execution context
* range new execution code range
*
* Output : Pointer to the code range record. NULL on failure.
*
*****************************************************************)
function Get_CodeRange( exec : PExec_Context;
range : Int ) : PCodeRange;
begin
if (range < 1) or (range > 3) then
Get_CodeRange := nil
else
Get_CodeRange := @exec^.codeRangeTable[range];
end;
(*******************************************************************
*
* Function : Set_CodeRange
*
* Description : Sets a code range.
*
* Input : exec target execution context
* range code range index
* base new code base
* length sange size in bytes
*
* Output : SUCCESS on success. FAILURE on error.
*
*****************************************************************)
function Set_CodeRange( exec : PExec_Context;
range : Int;
base : Pointer;
length : Int ) : TError;
begin
Set_CodeRange := Failure;
if (range < 1) or (range > 3) then
begin
error := TT_Err_Invalid_CodeRange;
exit;
end;
exec^.codeRangeTable[range].base := base;
exec^.codeRangeTable[range].size := length;
Set_CodeRange := Success;
end;
(*******************************************************************
*
* Function : Clear_CodeRange
*
* Description : clears a code range.
*
* Input : exec target execution context
* range code range index
*
* Output : SUCCESS on success. FAILURE on error.
*
* Notes : Does not set the Error variable.
*
*****************************************************************)
function Clear_CodeRange( exec : PExec_Context;
range : Int ) : TError;
begin
Clear_CodeRange := Failure;
if (range < 1) or (range > 3) then
begin
error := TT_Err_Invalid_CodeRange;
exit;
end;
exec^.codeRangeTable[range].base := nil;
exec^.codeRangeTable[range].size := 0;
Clear_CodeRange := Success;
end;
(****************************************************************)
(* *)
(* Management Functions *)
(* *)
(****************************************************************)
(*******************************************************************
*
* Function : Context_Destroy
*
* Description : Frees an execution context
*
* Input : context : execution context
*
* Notes : Allocation is found in the 'New_Context' function
*
******************************************************************)
function Context_Destroy( exec : Pointer ) : TError;
begin
Context_Destroy := Success;
if exec = nil then exit;
with PExec_Context(exec)^ do
begin
interpreter.Free;
interpreter := nil;
(* Free contours array *)
Free( pts.conEnds );
pts.n_contours := 0;
Free( pts.cur );
Free( pts.org );
Free( pts.flags );
pts.n_points := 0;
(* Free stack *)
Free( stack );
stackSize := 0;
(* Free call stack *)
Free( callStack );
callSize := 0;
(* Free composite load stack *)
Free( loadStack );
(* free glyph code range *)
Free( glyphIns );
glyphSize := 0;
instance := nil;
face := nil;
end;
end;
(*******************************************************************
*
* Function : Context_Create
*
* Description : Creates a new execution context
*
* Input : _context context record
* _face face record
*
******************************************************************)
function Context_Create( _context : Pointer;
_face : Pointer ) : TError;
var
exec : PExec_Context;
label
Fail_Memory;
begin
Context_Create := Failure;
exec := PExec_Context(_context);
exec^.face := PFace(_face);
with exec^ do
begin
interpreter := nil;
callSize := 32;
loadSize := face^.maxComponents + 1;
storeSize := face^.MaxProfile.maxStorage;
stackSize := face^.MaxProfile.maxStackElements + 32;
(* Allocate a little extra for broken fonts like Courbs.ttf *)
(* and Timesbs.ttf *)
//n_points := face^.maxPoints + 2;
(* Reserve glyph code range *)
if Alloc( glyphIns, face^.MaxProfile.maxSizeOfInstructions ) or
(* Reserve call stack *)
Alloc( callStack, callSize*sizeof(TCallRecord) ) or
(* Reserve stack *)
Alloc( stack, stackSize*sizeof(Long) ) then
(* we don't reserve the points and contours arrays anymore *)
(* as this will be performed automatically by a Context_Load *)
(* the same is true for the load stack *)
goto Fail_Memory;
maxPoints := 0;
maxContours := 0;
loadSize := 0;
loadStack := nil;
pts.n_points := 0;
pts.n_contours := 0;
instance := nil;
end;
Context_Create := Success;
exit;
Fail_Memory:
Context_Destroy(_context);
error := TT_Err_Out_Of_Memory;
exit;
end;
(*******************************************************************
*
* Function : Context_Run
*
* Description : Run a glyph's bytecode stream
*
* Input : exec context record
*
******************************************************************)
function Context_Run( exec : PExec_Context;
debug : Boolean ) : TError;
begin
Context_Run := Failure;
if Goto_CodeRange( exec, TT_CodeRange_Glyph, 0 ) then
exit;
with exec^ do
begin
zp0 := pts;
zp1 := pts;
zp2 := pts;
GS.gep0 := 1;
GS.gep1 := 1;
GS.gep2 := 1;
GS.projVector.x := $4000;
GS.projVector.y := $0000;
GS.freeVector := GS.projVector;
GS.dualVector := GS.projVector;
GS.round_state := 1;
GS.loop := 1;
end;
if not debug and Run_Ins( @exec^ ) then
begin
error := exec^.error;
exit;
end;
Context_Run := Success;
end;
(****************************************************************)
(* *)
(* Instance Update Functions *)
(* *)
(****************************************************************)
(*******************************************************************
*
* Function : Context_Load
*
* Description : loads instance data into a new execution context
*
*******************************************************************)
procedure Context_Load( exec : PExec_Context;
ins : PInstance );
procedure Update_Max( var size : Int;
mult : Int;
var buff;
new_max : Int );
begin
if size*mult < new_max then
begin
Free(buff);
Alloc( buff, new_max*mult );
size := new_max;
end;
end;
procedure Update_Points( max_points : Int;
max_contours : Int;
exec : PExec_Context );
begin
if exec^.maxPoints < max_points then
begin
Free( exec^.pts.org );
Free( exec^.pts.cur );
Free( exec^.pts.flags );
Alloc( exec^.pts.org, 2*sizeof(TT_F26dot6)*max_points );
Alloc( exec^.pts.cur, 2*sizeof(TT_F26dot6)*max_points );
Alloc( exec^.pts.flags, sizeof(Byte) *max_points );
exec^.maxPoints := max_points;
end;
if exec^.maxContours < max_contours then
begin
Free( exec^.pts.conEnds );
Alloc( exec^.pts.conEnds, sizeof(Short)*max_contours );
exec^.maxContours := max_contours;
end;
end;
begin
with exec^ do
begin
instance := ins;
face := ins^.owner;
numFDefs := ins^.numFDefs;
numIDefs := ins^.numIDefs;
maxFDefs := ins^.maxFDefs;
maxIDefs := ins^.maxIDefs;
FDefs := ins^.FDefs;
IDefs := ins^.IDefs;
maxFunc := ins^.maxFunc;
maxIns := ins^.maxIns;
metrics := ins^.metrics;
codeRangeTable := ins^.codeRangeTable;
storeSize := ins^.storeSize;
storage := ins^.storage;
twilight := ins^.twilight;
(* We reserve some extra space to deal with broken fonts *)
(* like Arial BS, Courier BS, etc.. *)
Update_Max( stackSize,
sizeof(Long),
stack,
face^.maxProfile.maxStackElements+32 );
Update_Max( loadSize,
sizeof(TSubglyph_Record),
loadStack,
face^.maxComponents+1 );
Update_Max( glyphSize,
sizeof(Byte),
glyphIns,
face^.maxProfile.maxSizeOfInstructions );
(* XXXX : Don't forget the phantom points !! *)
Update_Points( face^.maxPoints+2, face^.maxContours, exec );
pts.n_points := 0;
pts.n_contours := 0;
instruction_trap := false;
(* Set default graphics state *)
GS := ins^.GS;
cvtSize := ins^.cvtSize;
cvt := ins^.cvt;
end;
end;
procedure Context_Save( exec : PExec_Context;
ins : PInstance );
begin
with ins^ do
begin
error := exec^.error;
numFDefs := exec^.numFDefs;
numIDefs := exec^.numIDefs;
maxFunc := exec^.maxFunc;
maxIns := exec^.maxIns;
codeRangeTable := exec^.codeRangeTable;
(* Set default graphics state *)
GS := exec^.GS;
end;
end;
(*******************************************************************
*
* Function : Instance_Destroy
*
* Description : The Instance Record destructor.
*
*****************************************************************)
function Instance_Destroy( instance : Pointer ) : TError;
var
ins : PInstance;
begin
Instance_Destroy := Success;
ins := PInstance(instance);
if ins = nil then
exit;
with ins^ do
begin
if debug then
begin
context := nil;
debug := false;
end;
(* Free twilight zone *)
Free( twilight.org );
Free( twilight.cur );
Free( twilight.flags );
twilight.n_points := 0;
Free( cvt );
cvtSize := 0;
Free( storage );
storeSize := 0;
Free( FDefs );
Free( IDefs );
numFDefs := 0;
numIDefs := 0;
maxFDefs := 0;
maxIDefs := 0;
owner := nil;
valid := false;
end;
end;
(*******************************************************************
*
* Function : Instance_Create
*
* Description : The Instance constructor.
*
* This functions creates a new instance object for a given face
*
*****************************************************************)
function Instance_Create( _ins : Pointer;
_face : Pointer ) : TError;
label
Fail_Memory;
var
ins : PInstance;
face : PFace;
n_twilight : Int;
begin
Instance_Create := Failure;
{$IFDEF ASSERT}
if (_face = nil) then
Panic1('TTInst.Init_Instance : void argument' );
{$ENDIF}
face := PFace(_face);
ins := PInstance(_ins);
ins^.owner := face;
with face^, ins^ do
begin
(* Reserve function and instruction defs arrays *)
maxFDefs := maxProfile.maxFunctionDefs;
maxIDefs := maxProfile.maxInstructionDefs;
storeSize := maxProfile.maxStorage;
n_twilight := maxProfile.maxTwilightPoints;
if Alloc( FDefs, maxFDefs * sizeof(TDefRecord) ) or
Alloc( IDefs, maxIDefs * sizeof(TDefRecord) ) or
Alloc( storage, storeSize * sizeof(Long) ) or
Alloc( twilight.org, 2* n_twilight * sizeof(TT_F26Dot6) ) or
Alloc( twilight.cur, 2* n_twilight * sizeof(TT_F26Dot6) ) or
Alloc( twilight.flags, n_twilight )
then goto Fail_Memory;
twilight.n_points := n_twilight;
metrics.x_resolution := 96;
metrics.y_resolution := 96;
metrics.pointSize := 10;
metrics.x_scale2 := 1;
metrics.y_scale2 := 1;
metrics.scale2 := 1;
{ Reserve Control Value Table }
cvtSize := face^.cvtSize;
if Alloc( cvt, cvtSize * sizeof(Long) ) then
goto Fail_Memory;
end;
Instance_Create := Success;
exit;
Fail_Memory:
Instance_Destroy(ins);
(* free all partially allocated tables, including the instance record *)
error := TT_Err_Out_Of_Memory;
exit;
end;
(*******************************************************************
*
* Function : Instance_Init
*
* Description : Initializes a fresh new instance
* Executes the font program if any is found
*
* Input : ins the instance object to initialise
*
*****************************************************************)
function Instance_Init( ins : PInstance ) : TError;
var
exec : PExec_Context;
face : PFace;
label
Fin;
begin
Instance_Init := Failure;
face := ins^.owner;
if ins^.debug then
exec := ins^.context
else
exec := New_Context( ins );
(* debugging instances have their own context *)
if exec = nil then
begin
error := TT_Err_Could_Not_Find_Context;
exit;
end;
with ins^ do begin
GS := Default_GraphicsState;
numFDefs := 0;
numIDefs := 0;
maxFunc := -1;
maxIns := -1;
end;
Context_Load( exec, ins );
with exec^ do
begin
period := 64;
phase := 0;
threshold := 0;
with metrics do
begin
x_ppem := 10;
y_ppem := 10;
pointSize := 10;
x_scale1 := 0;
x_scale2 := 1;
y_scale1 := 0;
y_scale2 := 1;
scale1 := 0;
scale2 := 1;
ratio := 1 shl 16;
end;
instruction_trap := false;
cvtSize := ins^.cvtSize;
cvt := ins^.cvt;
F_dot_P := $10000;
end;
Set_CodeRange( exec,
TT_CodeRange_Font,
face^.fontProgram,
face^.fontPgmSize );
(* Allow font program execution *)
Clear_CodeRange( exec, TT_CodeRange_Cvt );
Clear_CodeRange( exec, TT_CodeRange_Glyph );
(* disable CVT and glyph programs coderanges *)
if face^.fontPgmSize > 0 then
begin
if Goto_CodeRange( exec, TT_CodeRange_Font, 0 ) then
goto Fin;
if Run_Ins( @exec^ ) then
begin
error := exec^.error;
goto Fin;
end;
end;
Instance_Init := Success;
Fin:
Context_Save( exec, ins );
if not ins^.debug then
Done_Context( exec );
ins^.valid := False;
end;
(*******************************************************************
*
* Function : Instance_Reset
*
* Description : Reset an instance to a new pointsize
* Executes the prep/cvt program if any is found
*
* Input : ins the instance object to initialise
*
*****************************************************************)
function Instance_Reset( ins : PInstance;
debug : boolean ) : TError;
var
exec : PExec_Context;
face : PFace;
i : Int;
label
Fin;
begin
Instance_Reset := Failure;
if ins^.valid then
begin
Instance_Reset := Success;
exit;
end;
face := ins^.owner;
(* compute new transform *)
with ins^.metrics do
begin
if x_ppem < 1 then x_ppem := 1;
if y_ppem < 1 then y_ppem := 1;
if x_ppem >= y_ppem then
begin
scale1 := x_scale1;
scale2 := x_scale2;
ppem := x_ppem;
x_ratio := 1 shl 16;
y_ratio := MulDiv_Round( y_ppem, $10000, x_ppem );
end
else
begin
scale1 := y_scale1;
scale2 := y_scale2;
ppem := y_ppem;
x_ratio := MulDiv_Round( x_ppem, $10000, y_ppem );
y_ratio := 1 shl 16
end;
end;
(* scale the cvt values to the new ppem *)
for i := 0 to ins^.cvtSize-1 do
ins^.cvt^[i] := MulDiv_Round( ins^.owner^.cvt^[i],
ins^.metrics.scale1,
ins^.metrics.scale2 );
(* Note that we use the y resolution by default to scale the cvt *)
ins^.GS := Default_GraphicsState;
if ins^.debug then
exec := ins^.context
else
exec := New_Context(ins);
if exec = nil then
begin
error := TT_Err_Could_Not_Find_Context;
exit;
end;
Context_Load( exec, ins );
Set_CodeRange( exec,
TT_CodeRange_CVT,
face^.cvtProgram,
face^.cvtPgmSize );
Clear_CodeRange( exec, TT_CodeRange_Glyph );
with exec^ do
begin
for i := 0 to storeSize-1 do
storage^[i] := 0;
instruction_trap := False;
(* all twilight points are originally zero *)
for i := 0 to twilight.n_points-1 do
begin
twilight.org^[i].x := 0;
twilight.org^[i].y := 0;
twilight.cur^[i].x := 0;
twilight.cur^[i].y := 0;
end;
end;
if face^.cvtPgmSize > 0 then
if Goto_CodeRange( exec, TT_CodeRange_CVT, 0 ) or
( (not debug) and Run_Ins( @exec^ ) ) then
goto Fin;
Instance_Reset := Success;
Fin:
Context_Save( exec, ins );
if not ins^.debug then
Done_Context(exec);
if error = 0 then
ins^.valid := True;
end;
(*******************************************************************
*
* Function : Face_Destroy
*
* Description : The face object destructor
*
*****************************************************************)
function Face_Destroy( _face : Pointer ) : TError;
var
face : PFace;
n : Int;
begin
Face_Destroy := Success;
face := PFace(_face);
if face = nil then exit;
Cache_Destroy( face^.instances );
Cache_Destroy( face^.glyphs );
face^.kernings.Free;
face^.kernings := nil;
(* freeing the tables directory *)
Free( face^.dirTables );
face^.numTables := 0;
(* freeing the locations table *)
Free( face^.glyphLocations );
face^.numLocations := 0;
(* freeing the character mapping tables *)
for n := 0 to face^.numCMaps-1 do
CharMap_Free( face^.cMaps^[n] );
Free( face^.cMaps );
face^.numCMaps := 0;
(* freeing the CVT *)
Free( face^.cvt );
face^.cvtSize := 0;
(* freeing the horizontal header *)
Free( face^.horizontalHeader.short_metrics );
Free( face^.horizontalHeader.long_metrics );
if face^.verticalInfo then
begin
Free( face^.verticalHeader.short_metrics );
Free( face^.verticalHeader.long_metrics );
face^.verticalInfo := False;
end;
(* freeing the programs *)
Free( face^.fontProgram );
Free( face^.cvtProgram );
face^.fontPgmSize := 0;
face^.cvtPgmSize := 0;
(* freeing the gasp table - none yet *)
Free( face^.gasp.gaspRanges );
(* freeing the names table *)
Free( face^.nameTable.names );
Free( face^.nameTable.storage );
face^.nameTable.numNameRecords := 0;
face^.nameTable.format := 0;
(* freeing the hdmx table *)
for n := 0 to face^.hdmx.num_records-1 do
Free( face^.hdmx.records^[n].widths );
Free( face^.hdmx.records );
face^.hdmx.num_records := 0;
TT_Close_Stream( face^.stream );
end;
(*******************************************************************
*
* Function : Face_Create
*
* Description : The face object constructor
*
*****************************************************************)
function Face_Create( _face : Pointer;
_input : Pointer ) : TError;
var
input : PFont_Input;
face : PFace;
ftstream: TFreeTypeStream;
label Fail;
begin
Face_Create := Failure;
face := PFace(_face);
input := PFont_Input(_input);
face^.stream := input^.stream;
if TT_Use_Stream(face^.stream, ftstream) then exit;
if Cache_Create( objs_instance_class, face^.instances ) or
Cache_Create( objs_glyph_class, face^.glyphs ) then goto Fail;
(* Load collection directory if present *)
if Load_TrueType_Directory( ftstream, face, input^.fontIndex ) then
goto Fail;
if Load_TrueType_Header ( ftstream, face ) or
Load_TrueType_MaxProfile ( ftstream, face ) or
Load_TrueType_Locations ( ftstream, face ) or
Load_TrueType_CMap ( ftstream, face ) or
Load_TrueType_CVT ( ftstream, face ) or
Load_TrueType_Metrics_Header ( ftstream, face, false ) or
Load_TrueType_Programs ( ftstream, face ) or
Load_TrueType_Gasp ( ftstream, face ) or
Load_TrueType_Names ( ftstream, face ) or
Load_TrueType_OS2 ( ftstream, face ) or
Load_TrueType_Hdmx ( ftstream, face ) or
Load_TrueType_Postscript ( ftstream, face ) or
Load_TrueType_Metrics_Header ( ftstream, face, true ) then
goto Fail;
Face_Create := Success;
TT_Done_Stream(face^.stream);
exit;
Fail:
TT_Done_Stream(face^.stream);
Face_Destroy( face );
exit;
end;
function Glyph_Destroy( _glyph : Pointer ) : TError;
var
glyph : PGlyph;
begin
Glyph_Destroy := Success;
glyph := PGlyph(_glyph);
if glyph = nil then
exit;
glyph^.outline.owner := true;
TT_Done_Outline( glyph^.outline );
end;
function Glyph_Create( _glyph : Pointer;
_face : Pointer ) : TError;
var
glyph : PGlyph;
begin
glyph := PGlyph(_glyph);
glyph^.face := PFace(_face);
error := TT_New_Outline( glyph^.face^.maxPoints+2,
glyph^.face^.maxContours,
glyph^.outline );
if error <> TT_Err_Ok then
Glyph_Create := Failure
else
Glyph_Create := Success;
end;
function Scale_X( var metrics : TIns_Metrics; x : TT_Pos ) : TT_Pos;
begin
Scale_X := MulDiv_Round( x, metrics.x_scale1, metrics.x_scale2 );
end;
function Scale_Y( var metrics : TIns_Metrics; y : TT_Pos ) : TT_Pos;
begin
Scale_Y := MulDiv_Round( y, metrics.y_scale1, metrics.y_scale2 );
end;
function TTObjs_Init : TError;
begin
TTObjs_Init := Failure;
Cache_Create( objs_face_class, face_cache );
Cache_Create( objs_exec_class, exec_cache );
TTObjs_Init := success;
end;
procedure TTObjs_Done;
begin
Cache_Destroy( face_cache );
Cache_Destroy( exec_cache );
end;
end.
Reference in New Issue View Git Blame Copy Permalink