paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-02 23:23:48 +02:00
Code Issues Packages Projects Releases Wiki Activity
222d3f6e64
lazarus/components/lazutils/ttinterp.pas
sekelsenmat 5d9dce28f6 Patch from circular to improve LazFreeType 
git-svn-id: trunk@36242 -
2012-03-23 06:41:02 +00:00

4777 lines
132 KiB
ObjectPascal
Raw Blame History

(*******************************************************************
*
* TTInterp.pas 2.0
*
* TrueType bytecode intepreter.
*
* 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.
*
*
* Changes between 2.0 and 1.2 :
*
* - Lots, lots, of changes : This version is not re-entrant,
* but much faster.
*
*
******************************************************************)
unit TTInterp;
interface
{$mode Delphi}
uses TTTypes,
TTObjs;
function Run_Ins( exec : PExec_Context ) : Boolean;
(* Run the interpreter with the current code range and IP *)
implementation
uses
TTCalc;
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;
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;
type
TInstruction_Function = procedure( args : PStorage );
const
Null_Vector : TT_Vector = (x:0;y:0);
var
exc : TExec_Context; (* static variable *)
const
(*********************************************************************)
(* *)
(* Before an opcode is executed, the interpreter verifies that *)
(* there are enough arguments on the stack, with the help of *)
(* the Pop_Push_Count table. *)
(* *)
(* Note that for opcodes with a varying numbre of parameters, *)
(* either 0 or 1 arg is verified before execution, depending *)
(* on the nature of the instruction : *)
(* *)
(* - if the number of arguments is given by the bytecode *)
(* stream or the loop variable, 0 is chosen. *)
(* *)
(* - if the first argument is a count n that is followed *)
(* by arguments a1..an, then 1 is chosen. *)
(* *)
(*********************************************************************)
Pop_Push_Count : array[0..511] of byte
= (
(* SVTCA y *) 0, 0,
(* SVTCA x *) 0, 0,
(* SPvTCA y *) 0, 0,
(* SPvTCA x *) 0, 0,
(* SFvTCA y *) 0, 0,
(* SFvTCA x *) 0, 0,
(* SPvTL // *) 2, 0,
(* SPvTL + *) 2, 0,
(* SFvTL // *) 2, 0,
(* SFvTL + *) 2, 0,
(* SPvFS *) 2, 0,
(* SFvFS *) 2, 0,
(* GPV *) 0, 2,
(* GFV *) 0, 2,
(* SFvTPv *) 0, 0,
(* ISECT *) 5, 0,
(* SRP0 *) 1, 0,
(* SRP1 *) 1, 0,
(* SRP2 *) 1, 0,
(* SZP0 *) 1, 0,
(* SZP1 *) 1, 0,
(* SZP2 *) 1, 0,
(* SZPS *) 1, 0,
(* SLOOP *) 1, 0,
(* RTG *) 0, 0,
(* RTHG *) 0, 0,
(* SMD *) 1, 0,
(* ELSE *) 0, 0,
(* JMPR *) 1, 0,
(* SCvTCi *) 1, 0,
(* SSwCi *) 1, 0,
(* SSW *) 1, 0,
(* DUP *) 1, 2,
(* POP *) 1, 0,
(* CLEAR *) 0, 0,
(* SWAP *) 2, 2,
(* DEPTH *) 0, 1,
(* CINDEX *) 1, 1,
(* MINDEX *) 1, 0, (* first arg *)
(* AlignPTS *) 2, 0,
(* INS_$28 *) 0, 0,
(* UTP *) 1, 0,
(* LOOPCALL *) 2, 0,
(* CALL *) 1, 0,
(* FDEF *) 1, 0,
(* ENDF *) 0, 0,
(* MDAP[0] *) 1, 0,
(* MDAP[1] *) 1, 0,
(* IUP[0] *) 0, 0,
(* IUP[1] *) 0, 0,
(* SHP[0] *) 0, 0, (* no args *)
(* SHP[1] *) 0, 0, (* no args *)
(* SHC[0] *) 1, 0,
(* SHC[1] *) 1, 0,
(* SHZ[0] *) 1, 0,
(* SHZ[1] *) 1, 0,
(* SHPIX *) 1, 0, (* first arg *)
(* IP *) 0, 0, (* no args *)
(* MSIRP[0] *) 2, 0,
(* MSIRP[1] *) 2, 0,
(* AlignRP *) 0, 0, (* no args *)
(* RTDG *) 0, 0,
(* MIAP[0] *) 2, 0,
(* MIAP[1] *) 2, 0,
(* NPushB *) 0, 0,
(* NPushW *) 0, 0,
(* WS *) 2, 0,
(* RS *) 1, 1,
(* WCvtP *) 2, 0,
(* RCvt *) 1, 1,
(* GC[0] *) 1, 1,
(* GC[1] *) 1, 1,
(* SCFS *) 2, 0,
(* MD[0] *) 2, 1,
(* MD[1] *) 2, 1,
(* MPPEM *) 0, 1,
(* MPS *) 0, 1,
(* FlipON *) 0, 0,
(* FlipOFF *) 0, 0,
(* DEBUG *) 1, 0,
(* LT *) 2, 1,
(* LTEQ *) 2, 1,
(* GT *) 2, 1,
(* GTEQ *) 2, 1,
(* EQ *) 2, 1,
(* NEQ *) 2, 1,
(* ODD *) 1, 1,
(* EVEN *) 1, 1,
(* IF *) 1, 0,
(* EIF *) 0, 0,
(* AND *) 2, 1,
(* OR *) 2, 1,
(* NOT *) 1, 1,
(* DeltaP1 *) 1, 0, (* first arg *)
(* SDB *) 1, 0,
(* SDS *) 1, 0,
(* ADD *) 2, 1,
(* SUB *) 2, 1,
(* DIV *) 2, 1,
(* MUL *) 2, 1,
(* ABS *) 1, 1,
(* NEG *) 1, 1,
(* FLOOR *) 1, 1,
(* CEILING *) 1, 1,
(* ROUND[0] *) 1, 1,
(* ROUND[1] *) 1, 1,
(* ROUND[2] *) 1, 1,
(* ROUND[3] *) 1, 1,
(* NROUND[0]*) 1, 1,
(* NROUND[1]*) 1, 1,
(* NROUND[2]*) 1, 1,
(* NROUND[3]*) 1, 1,
(* WCvtF *) 2, 0,
(* DeltaP2 *) 1, 0, (* first arg *)
(* DeltaP3 *) 1, 0, (* first arg *)
(* DeltaCn[0]*) 1, 0, (* first arg *)
(* DeltaCn[1]*) 1, 0, (* first arg *)
(* DeltaCn[2]*) 1, 0, (* first arg *)
(* SROUND *) 1, 0,
(* S45Round *) 1, 0,
(* JROT *) 2, 0,
(* JROF *) 2, 0,
(* ROFF *) 0, 0,
(* INS_$7B *) 0, 0,
(* RUTG *) 0, 0,
(* RDTG *) 0, 0,
(* SANGW *) 1, 0,
(* AA *) 1, 0,
(* FlipPT *) 0, 0, (* no args *)
(* FlipRgON *) 2, 0,
(* FlipRgOFF*) 2, 0,
(* INS_$83 *) 0, 0,
(* INS_$84 *) 0, 0,
(* ScanCTRL *) 1, 0,
(* SDVPTL[0]*) 2, 0,
(* SDVPTL[1]*) 2, 0,
(* GetINFO *) 1, 1,
(* IDEF *) 1, 0,
(* ROLL *) 3, 3, (* pops 3 args/push 3 args *)
(* MAX *) 2, 1,
(* MIN *) 2, 1,
(* ScanTYPE *) 1, 0,
(* InstCTRL *) 2, 0,
(* INS_$8F *) 0, 0,
(* INS_$90 *) 0, 0,
(* INS_$91 *) 0, 0,
(* INS_$92 *) 0, 0,
(* INS_$93 *) 0, 0,
(* INS_$94 *) 0, 0,
(* INS_$95 *) 0, 0,
(* INS_$96 *) 0, 0,
(* INS_$97 *) 0, 0,
(* INS_$98 *) 0, 0,
(* INS_$99 *) 0, 0,
(* INS_$9A *) 0, 0,
(* INS_$9B *) 0, 0,
(* INS_$9C *) 0, 0,
(* INS_$9D *) 0, 0,
(* INS_$9E *) 0, 0,
(* INS_$9F *) 0, 0,
(* INS_$A0 *) 0, 0,
(* INS_$A1 *) 0, 0,
(* INS_$A2 *) 0, 0,
(* INS_$A3 *) 0, 0,
(* INS_$A4 *) 0, 0,
(* INS_$A5 *) 0, 0,
(* INS_$A6 *) 0, 0,
(* INS_$A7 *) 0, 0,
(* INS_$A8 *) 0, 0,
(* INS_$A9 *) 0, 0,
(* INS_$AA *) 0, 0,
(* INS_$AB *) 0, 0,
(* INS_$AC *) 0, 0,
(* INS_$AD *) 0, 0,
(* INS_$AE *) 0, 0,
(* INS_$AF *) 0, 0,
(* PushB[0] *) 0, 1,
(* PushB[1] *) 0, 2,
(* PushB[2] *) 0, 3,
(* PushB[3] *) 0, 4,
(* PushB[4] *) 0, 5,
(* PushB[5] *) 0, 6,
(* PushB[6] *) 0, 7,
(* PushB[7] *) 0, 8,
(* PushW[0] *) 0, 1,
(* PushW[1] *) 0, 2,
(* PushW[2] *) 0, 3,
(* PushW[3] *) 0, 4,
(* PushW[4] *) 0, 5,
(* PushW[5] *) 0, 6,
(* PushW[6] *) 0, 7,
(* PushW[7] *) 0, 8,
(* MDRP[00] *) 1, 0,
(* MDRP[01] *) 1, 0,
(* MDRP[02] *) 1, 0,
(* MDRP[03] *) 1, 0,
(* MDRP[04] *) 1, 0,
(* MDRP[05] *) 1, 0,
(* MDRP[06] *) 1, 0,
(* MDRP[07] *) 1, 0,
(* MDRP[08] *) 1, 0,
(* MDRP[09] *) 1, 0,
(* MDRP[10] *) 1, 0,
(* MDRP[11] *) 1, 0,
(* MDRP[12] *) 1, 0,
(* MDRP[13] *) 1, 0,
(* MDRP[14] *) 1, 0,
(* MDRP[15] *) 1, 0,
(* MDRP[16] *) 1, 0,
(* MDRP[17] *) 1, 0,
(* MDRP[18] *) 1, 0,
(* MDRP[19] *) 1, 0,
(* MDRP[20] *) 1, 0,
(* MDRP[21] *) 1, 0,
(* MDRP[22] *) 1, 0,
(* MDRP[23] *) 1, 0,
(* MDRP[24] *) 1, 0,
(* MDRP[25] *) 1, 0,
(* MDRP[26] *) 1, 0,
(* MDRP[27] *) 1, 0,
(* MDRP[28] *) 1, 0,
(* MDRP[29] *) 1, 0,
(* MDRP[30] *) 1, 0,
(* MDRP[31] *) 1, 0,
(* MIRP[00] *) 2, 0,
(* MIRP[01] *) 2, 0,
(* MIRP[02] *) 2, 0,
(* MIRP[03] *) 2, 0,
(* MIRP[04] *) 2, 0,
(* MIRP[05] *) 2, 0,
(* MIRP[06] *) 2, 0,
(* MIRP[07] *) 2, 0,
(* MIRP[08] *) 2, 0,
(* MIRP[09] *) 2, 0,
(* MIRP[10] *) 2, 0,
(* MIRP[11] *) 2, 0,
(* MIRP[12] *) 2, 0,
(* MIRP[13] *) 2, 0,
(* MIRP[14] *) 2, 0,
(* MIRP[15] *) 2, 0,
(* MIRP[16] *) 2, 0,
(* MIRP[17] *) 2, 0,
(* MIRP[18] *) 2, 0,
(* MIRP[19] *) 2, 0,
(* MIRP[20] *) 2, 0,
(* MIRP[21] *) 2, 0,
(* MIRP[22] *) 2, 0,
(* MIRP[23] *) 2, 0,
(* MIRP[24] *) 2, 0,
(* MIRP[25] *) 2, 0,
(* MIRP[26] *) 2, 0,
(* MIRP[27] *) 2, 0,
(* MIRP[28] *) 2, 0,
(* MIRP[29] *) 2, 0,
(* MIRP[30] *) 2, 0,
(* MIRP[31] *) 2, 0
);
(*******************************************************************
*
* Function : Norm
*
* Description : returns the norm (length) of a vector
*
* Input : X, Y vector
*
* Output : returns length in F26dot6
*
*****************************************************************)
function Norm( X, Y : TT_F26dot6 ): TT_F26dot6;
begin
result := sqrt64(int64(X)*int64(X)+int64(Y)*int64(Y));
end;
(*******************************************************************
*
* Function : Scale_Pixels
*
* Description : Converts from FUnits to Fractional pixels
* coordinates.
*
*****************************************************************)
function Scale_Pixels( value : long ) : TT_F26Dot6;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Scale_Pixels := MulDiv_Round( value,
exc.metrics.scale1,
exc.metrics.scale2 );
end;
function Get_Current_Ratio : Long;
var
x, y : Long;
begin
if exc.metrics.ratio <> 0 then
Get_Current_Ratio := exc.metrics.ratio
else
begin
if exc.GS.projVector.y = 0 then
exc.metrics.ratio := exc.metrics.x_ratio
else if exc.GS.projVector.x = 0 then
exc.metrics.ratio := exc.metrics.y_ratio
else
begin
x := MulDiv_Round( exc.GS.projVector.x,
exc.metrics.x_ratio,
$4000 );
y := MulDiv_Round( exc.GS.projVector.y,
exc.metrics.y_ratio,
$4000 );
exc.metrics.ratio := Norm( x, y );
end;
Get_Current_Ratio := exc.metrics.ratio;
end
end;
function Get_Ppem : Long;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Get_Ppem := MulDiv_Round( exc.metrics.ppem, Get_Current_Ratio, $10000 );
end;
function Read_CVT( index : Int ) : TT_F26Dot6;
begin
Read_CVT := exc.cvt^[index];
end;
function Read_CVT_Stretched( index : Int ) : TT_F26Dot6;
begin
Read_CVT_Stretched := MulDiv_Round( exc.cvt^[index],
Get_Current_Ratio,
$10000 );
end;
procedure Write_CVT( index : Int; value : TT_F26Dot6 );
begin
exc.cvt^[index] := value;
end;
procedure Write_CVT_Stretched( index : Int; value : TT_F26Dot6 );
begin
exc.cvt^[index] := MulDiv_Round( value,
$10000,
Get_Current_Ratio );
end;
procedure Move_CVT( index : Int; value : TT_F26Dot6 );
begin
inc( exc.cvt^[index], value );
end;
procedure Move_CVT_Stretched( index : Int; value : TT_F26dot6 );
begin
inc( exc.cvt^[index], MulDiv_Round( value,
$10000,
Get_Current_Ratio ));
end;
(*******************************************************************
*
* Function : Calc_Length
*
* Description : Computes the length in bytes of current opcode
*
*****************************************************************)
function Calc_Length : boolean;
begin
Calc_Length := false;
exc.opcode := exc.Code^[exc.IP];
case exc.opcode of
$40 : if exc.IP+1 >= exc.codeSize
then exit
else
exc.length := exc.code^[exc.IP+1] + 2;
$41 : if exc.IP+1 >= exc.codeSize
then exit
else
exc.length := exc.code^[exc.IP+1]*2 + 2;
$B0..$B7 : exc.length := exc.opcode-$B0 + 2;
$B8..$BF : exc.length := (exc.opcode-$B8)*2 + 3;
else
exc.length := 1;
end;
Calc_Length := exc.IP+exc.length <= exc.codeSize;
end;
(*******************************************************************
*
* Function : Get_Short
*
* Description : Return a short integer taken from the instruction
* stream at address IP.
*
* Input : None
*
* Output : Short read at Code^[IP..IP+1]
*
* Notes : This one could become a Macro in the C version
*
*****************************************************************)
function GetShort : Short;
var
L : Array[0..1] of Byte;
resultat : Short absolute L; (* XXX : un-portable *)
begin
(* This is little-endian code *)
L[1] := exc.code^[exc.IP]; inc(exc.IP);
L[0] := exc.code^[exc.IP]; inc(exc.IP);
GetShort := resultat;
end;
function Goto_CodeRange( aRange,
aIP : Int ): boolean;
begin
Goto_CodeRange := False;
with exc do
begin
if (aRange<1) or (aRange>3) then
begin
exc.error := TT_Err_Bad_Argument;
exit;
end;
with CodeRangeTable[ARange] do
begin
if Base = nil then (* invalid coderange *)
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 AIP <= Size, instead of AIP < Size *)
if AIP > Size then
begin
error := TT_Err_Code_Overflow;
Goto_CodeRange := False;
exit;
end;
Code := PByte(Base);
CodeSize := Size;
IP := AIP;
end;
curRange := ARange;
end;
Goto_CodeRange := True;
end;
(*******************************************************************
*
* Function : Direct_Move
*
* Description : Moves a point by a given distance along the
* freedom vector.
*
* Input : Vx, Vy point coordinates to move
* touch touch flag to modify
* distance
*
* Output : None
*
*****************************************************************)
procedure Direct_Move( zone : PGlyph_Zone;
point : Int;
distance : TT_F26dot6 );
var
v : TT_F26dot6;
begin
v := exc.GS.freeVector.x;
if v <> 0 then
begin
inc( zone^.cur^[point].x, MulDiv_Round( distance,
Long(v)*$10000,
exc.F_dot_P ));
zone^.flags^[point] := zone^.flags^[point] or TT_Flag_Touched_X;
end;
v := exc.GS.freeVector.y;
if v <> 0 then
begin
inc( zone^.cur^[point].y, MulDiv_Round( distance,
Long(v)*$10000,
exc.F_dot_P ));
zone^.flags^[point] := zone^.flags^[point] or TT_Flag_Touched_Y;
end;
end;
(* The following versions are used whenever both vectors are both *)
(* along one of the coordinate unit vectors, i.e. in 90% cases *)
procedure Direct_Move_X( zone : PGlyph_Zone;
point : Int;
distance : TT_F26dot6 );
begin
inc( zone^.cur^[point].x, distance );
zone^.flags^[point] := zone^.flags^[point] or TT_Flag_Touched_X;
end;
procedure Direct_Move_Y( zone : PGlyph_Zone;
point : Int;
distance : TT_F26dot6 );
begin
inc( zone^.cur^[point].y, distance );
zone^.flags^[point] := zone^.flags^[point] or TT_Flag_Touched_Y;
end;
(*******************************************************************
*
* Function : Round_None
*
* Description : Do not round, but add engine compensation
*
* Input : distance : distance to round
* compensation : engine compensation
*
* Output : rounded distance
*
* NOTE : The spec says very few about the relationship between
* rounding and engine compensation. However, it seems
* from the description of super round that we should
* should add the compensation before rounding
*
*****************************************************************)
function Round_None( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
if distance >= 0 then
begin
val := distance + compensation;
if val < 0 then val := 0;
end
else
begin
val := distance - compensation;
if val > 0 then val := 0;
end;
Round_None := val;
end;
(*******************************************************************
*
* Function : Round_To_Grid
*
* Description : round value to grid after adding engine
* compensation
*
* Input : distance : distance to round
* compensation : engine compensation
*
* Output : rounded distance
*
*****************************************************************)
function Round_To_Grid( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
if distance >= 0 then
begin
val := (distance + 32 + compensation) and -64;
if val < 0 then val := 0;
end
else
begin
val := - ((compensation - distance + 32) and -64);
if val > 0 then val := 0;
end;
Round_To_Grid := val;
end;
(*******************************************************************
*
* Function : Round_To_Half_Grid
*
* Description : round value to half grid after adding engine
* compensation
*
* Input : distance : distance to round
* compensation : engine compensation
*
* Output : rounded distance
*
*****************************************************************)
function Round_To_Half_Grid( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
if distance >= 0 then
begin
val := (distance + compensation) and -64 + 32;
if val < 0 then val := 0;
end
else
begin
val := - ((-distance + compensation) and -64 + 32);
if val > 0 then val := 0;
end;
Round_To_Half_Grid := val;
end;
(*******************************************************************
*
* Function : Round_Down_To_Grid
*
* Description : round value down to grid after adding engine
* compensation
*
* Input : distance : distance to round
* compensation : engine compensation
*
* Output : rounded distance
*
*****************************************************************)
function Round_Down_To_Grid( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
if distance >= 0 then
begin
val := (distance + compensation) and -64;
if val < 0 then val := 0;
end
else
begin
val := - ((-distance + compensation) and -64);
if val > 0 then val := 0;
end;
Round_Down_To_Grid := val;
end;
(*******************************************************************
*
* Function : Round_Up_To_Grid
*
* Description : round value up to grid after adding engine
* compensation
*
* Input : distance : distance to round
* compensation : engine compensation
*
* Output : rounded distance
*
*****************************************************************)
function Round_Up_To_Grid( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
if distance >= 0 then
begin
val := (distance + 63 + compensation) and -64;
if val < 0 then val := 0;
end
else
begin
val := - ((-distance + 63 + compensation) and -64);
if val > 0 then val := 0;
end;
Round_Up_To_Grid := val;
end;
(*******************************************************************
*
* Function : Round_To_Double_Grid
*
* Description : round value to double grid after adding engine
* compensation
*
* Input : distance : distance to round
* compensation : engine compensation
*
* Output : rounded distance
*
*****************************************************************)
function Round_To_Double_Grid( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
if distance >= 0 then
begin
val := (distance + 16 + compensation) and -32;
if val < 0 then val := 0;
end
else
begin
val := - ((-distance + 16 + compensation) and -32);
if val > 0 then val := 0;
end;
Round_To_Double_Grid := val;
end;
(*******************************************************************
*
* Function : Round_Super
*
* Description : super round value to grid after adding engine
* compensation
*
* Input : distance : distance to round
* compensation : engine compensation
*
* Output : rounded distance
*
* NOTE : The spec says very few about the relationship between
* rounding and engine compensation. However, it seems
* from the description of super round that we should
* should add the compensation before rounding
*
*****************************************************************)
function Round_Super( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
with exc do
if distance >= 0 then
begin
val := (distance - phase + threshold + compensation) and -period;
if val < 0 then val := 0;
val := val + phase;
end
else
begin
val := -((-distance - phase + threshold + compensation) and -period);
if val > 0 then val := 0;
val := val - phase;
end;
Round_Super := val;
end;
(*******************************************************************
*
* Function : Round_Super_45
*
* Description : super round value to grid after adding engine
* compensation
*
* Input : distance : distance to round
* compensation : engine compensation
*
* Output : rounded distance
*
* NOTE : There is a separate function for Round_Super_45 as we
* may need a greater precision.
*
*****************************************************************)
function Round_Super_45( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
with exc do
if distance >= 0 then
begin
val := ((distance - phase + threshold + compensation) div period)
* period;
if val < 0 then val := 0;
val := val + phase;
end
else
begin
val := -((-distance - phase + threshold + compensation) div period
* period );
if val > 0 then val := 0;
val := val - phase;
end;
Round_Super_45 := val;
end;
procedure Compute_Round( round_mode : Byte );
begin
case Round_Mode of
{$IFDEF FPC}
TT_Round_Off : exc.func_round := @Round_None;
TT_Round_To_Grid : exc.func_round := @Round_To_Grid;
TT_Round_Up_To_Grid : exc.func_round := @Round_Up_To_Grid;
TT_Round_Down_To_Grid : exc.func_round := @Round_Down_To_Grid;
TT_Round_To_Half_Grid : exc.func_round := @Round_To_Half_Grid;
TT_Round_To_Double_Grid : exc.func_round := @Round_To_Double_Grid;
TT_Round_Super : exc.func_round := @Round_Super;
TT_Round_Super_45 : exc.func_round := @Round_Super_45;
{$ELSE}
TT_Round_Off : exc.func_round := Round_None;
TT_Round_To_Grid : exc.func_round := Round_To_Grid;
TT_Round_Up_To_Grid : exc.func_round := Round_Up_To_Grid;
TT_Round_Down_To_Grid : exc.func_round := Round_Down_To_Grid;
TT_Round_To_Half_Grid : exc.func_round := Round_To_Half_Grid;
TT_Round_To_Double_Grid : exc.func_round := Round_To_Double_Grid;
TT_Round_Super : exc.func_round := Round_Super;
TT_Round_Super_45 : exc.func_round := Round_Super_45;
{$ENDIF}
end;
end;
(*******************************************************************
*
* Function : SetSuperRound
*
* Description : Set Super Round parameters
*
* Input : GridPeriod Grid period
* OpCode SROUND opcode
*
* Output : None
*
* Notes :
*
*****************************************************************)
procedure SetSuperRound( GridPeriod : TT_F26dot6; selector : Long );
begin
with exc do
begin
Case selector and $C0 of
$00 : period := GridPeriod div 2;
$40 : period := GridPeriod;
$80 : period := GridPeriod * 2;
(* This opcode is reserved, but ... *)
$C0 : period := GridPeriod;
end;
Case selector and $30 of
$00 : phase := 0;
$10 : phase := period div 4;
$20 : phase := period div 2;
$30 : phase := gridPeriod*3 div 4;
end;
if selector and $F = 0 then
Threshold := Period-1
else
Threshold := (Integer( selector and $F )-4)*period div 8;
period := period div 256;
phase := phase div 256;
threshold := threshold div 256;
end
end;
(*******************************************************************
*
* Function : Project
*
* Description : Computes the projection of (Vx,Vy) along the
* current projection vector
*
* Input : Vx, Vy input vector
*
* Output : return distance in F26dot6
*
*****************************************************************)
function Project( var P1, P2 : TT_Vector ) : TT_F26dot6;
var
T1, T2 : Int64;
begin
with exc.GS.projVector do
begin
MulTo64( P1.x - P2.x, x, T1 );
MulTo64( P1.y - P2.y, y, T2 );
end;
Project := Div64by32( T1+T2, $4000 );
end;
function Dual_Project( var P1, P2 : TT_Vector ) : TT_F26dot6;
var
T1, T2 : Int64;
begin
with exc.GS.dualVector do
begin
MulTo64( P1.x - P2.x, x, T1 );
MulTo64( P1.y - P2.y, y, T2 );
end;
Dual_Project := Div64by32( T1+T2, $4000 );
end;
function Free_Project( var P1, P2 : TT_Vector ) : TT_F26dot6;
var
T1, T2 : Int64;
begin
with exc.GS.freeVector do
begin
MulTo64( P1.x - P2.x, x, T1 );
MulTo64( P1.y - P2.y, y, T2 );
end;
Free_Project := Div64by32( T1+T2, $4000 );
end;
function Project_x( var P1, P2 : TT_Vector ) : TT_F26dot6;
begin
Project_x := P1.x - P2.x;
end;
function Project_y( var P1, P2 : TT_Vector ) : TT_F26dot6;
begin
Project_y := P1.y - P2.y;
end;
(*******************************************************************
*
* Function : Compute_Funcs
*
* Description : Computes the projections and movement function
* pointers according to the current graphics state
*
* Input : None
*
*****************************************************************)
procedure Compute_Funcs;
begin
with exc, GS do
begin
if (freeVector.x = $4000) then
begin
{$IFDEF FPC}
func_freeProj := @Project_x;
{$ELSE}
func_freeProj := Project_x;
{$ENDIF}
F_dot_P := Long(projVector.x) * $10000;
end
else
if (freeVector.y = $4000) then
begin
{$IFDEF FPC}
func_freeProj := @Project_y;
{$ELSE}
func_freeProj := Project_y;
{$ENDIF}
F_dot_P := Long(projVector.y) * $10000;
end
else
begin
{$IFDEF FPC}
func_move := @Direct_Move;
func_freeProj := @Free_Project;
{$ELSE}
func_move := Direct_Move;
func_freeProj := Free_Project;
{$ENDIF}
F_dot_P := Long(projVector.x) * freeVector.x * 4 +
Long(projVector.y) * freeVector.y * 4;
end;
{$IFDEF FPC}
if (projVector.x = $4000) then func_Project := @Project_x
else
if (projVector.y = $4000) then func_Project := @Project_y
else
func_Project := @Project;
if (dualVector.x = $4000) then func_dualproj := @Project_x
else
if (dualVector.y = $4000) then func_dualproj := @Project_y
else
func_dualproj := @Dual_Project;
func_move := @Direct_Move;
if F_dot_P = $40000000 then
if freeVector.x = $4000 then func_move := @Direct_Move_x
else
if freeVector.y = $4000 then func_move := @Direct_Move_y;
{$ELSE}
if (projVector.x = $4000) then func_Project := Project_x
else
if (projVector.y = $4000) then func_Project := Project_y
else
func_Project := Project;
if (dualVector.x = $4000) then func_dualproj := Project_x
else
if (dualVector.y = $4000) then func_dualproj := Project_y
else
func_dualproj := Dual_Project;
func_move := Direct_Move;
if F_dot_P = $40000000 then
if freeVector.x = $4000 then func_move := Direct_Move_x
else
if freeVector.y = $4000 then func_move := Direct_Move_y;
{$ENDIF}
(* at small sizes, F_dot_P can become too small, resulting *)
(* in overflows and 'spikes' in a number of glyfs like 'w' *)
if abs( F_dot_P ) < $4000000 then F_dot_P := $40000000;
(* set aspect ratio to 0 to force recomputation by Get_Current_Ratio *)
metrics.ratio := 0;
end;
end;
(**************************************************)
(* *)
(* Normalize : Normer un vecteur ( U, V ) *)
(* r<>sultat dans ( X, Y ) *)
(* False si vecteur param<61>tre nul *)
(* *)
(**************************************************)
function Normalize( U, V : TT_F26dot6; var R : TT_UnitVector ): boolean;
var
W : TT_F26dot6;
S1, S2 : Boolean;
begin
if (Abs(U) < $10000) and (Abs(V) < $10000) then
begin
U := U*$100;
V := V*$100;
W := Norm( U, V );
if W = 0 then
begin
(* XXX : Undocumented. Apparently, it is possible to try *)
(* to normalize the vector (0,0). Return success *)
(* in this case *)
Normalize := SUCCESS;
exit;
end;
R.x := MulDiv( U, $4000, W );
R.y := MulDiv( V, $4000, W );
end
else
begin
W := Norm( U, V );
if W > 0 then
begin
U := MulDiv( U, $4000, W );
V := MulDiv( V, $4000, W );
W := U*U + V*V;
(* Now, we want that Sqrt( W ) = $4000 *)
(* Or $1000000 <= W < $1004000 *)
if U < 0 then begin U := -U; S1 := True; end else S1 := False;
if V < 0 then begin V := -V; S2 := True; end else S2 := False;
while W < $1000000 do
begin
(* We need to increase W, by a minimal amount *)
if U < V then inc( U )
else inc( V );
W := U*U + V*V;
end;
while W >= $1004000 do
begin
(* We need to decrease W, by a minimal amount *)
if U < V then dec( U )
else dec( V );
W := U*U + V*V;
end;
(* Note that in various cases, we can only *)
(* compute a Sqrt(W) of $3FFF, eg. U=V *)
if S1 then U := -U;
if S2 then V := -V;
R.x := U; (* Type conversion *)
R.y := V; (* Type conversion *)
end
else
begin
Normalize := False;
exc.error := TT_Err_Divide_By_Zero;
end;
end;
Normalize := True;
end;
(****************************************************************)
(* *)
(* MANAGING THE STACK *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* DUP[] : Duplicate top stack element *)
(* CodeRange : $20 *)
procedure Ins_DUP( args : PStorage );
begin
args^[1] := args^[0];
end;
(*******************************************)
(* POP[] : POPs the stack's top elt. *)
(* CodeRange : $21 *)
procedure Ins_POP( {%H-}args : PStorage );
begin
(* nothing to do *)
end;
(*******************************************)
(* CLEAR[] : Clear the entire stack *)
(* CodeRange : $22 *)
procedure Ins_CLEAR( {%H-}args : PStorage );
begin
exc.new_top := 0;
end;
(*******************************************)
(* SWAP[] : Swap the top two elements *)
(* CodeRange : $23 *)
procedure Ins_SWAP( args : PStorage );
var L : Long;
begin
L := args^[0];
args^[0] := args^[1];
args^[1] := L;
end;
(*******************************************)
(* DEPTH[] : return the stack depth *)
(* CodeRange : $24 *)
procedure Ins_DEPTH( args : PStorage );
begin
args^[0] := exc.top;
end;
(*******************************************)
(* CINDEX[] : copy indexed element *)
(* CodeRange : $25 *)
procedure Ins_CINDEX( args : PStorage );
var
L : Long;
begin
L := args^[0];
if (L <= 0) or (L > exc.args) then
exc.error := TT_Err_Invalid_Reference
else
args^[0] := exc.stack^[exc.args-l];
end;
(*******************************************)
(* MINDEX[] : move indexed element *)
(* CodeRange : $26 *)
procedure Ins_MINDEX( args : PStorage );
var
L, K : Long;
begin
L := args^[0];
if (L <= 0) or (L > exc.args) then
exc.Error := TT_Err_Invalid_Reference
else
begin
K := exc.stack^[exc.args-L];
move( exc.stack^[exc.args-L+1],
exc.stack^[exc.args-L],
(L-1)*sizeof(Long) );
exc.stack^[exc.args-1] := K;
end;
end;
(*******************************************)
(* ROLL[] : roll top three elements *)
(* CodeRange : $8A *)
procedure Ins_ROLL( args : PStorage );
var
A, B, C : Long;
begin
A := args^[2];
B := args^[1];
C := args^[0];
args^[2] := C;
args^[1] := A;
args^[0] := B;
end;
(****************************************************************)
(* *)
(* MANAGING THE FLOW OF CONTROL *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
function SkipCode : boolean;
var
b : Boolean;
begin
b := False;
inc( exc.IP, exc.length );
b := exc.IP < exc.codeSize;
if b then b := Calc_Length;
if not b then
exc.error := TT_Err_Code_Overflow;
SkipCode := b;
end;
(*******************************************)
(* IF[] : IF test *)
(* CodeRange : $58 *)
procedure Ins_IF( args : PStorage );
var
nIfs : Int;
Out : Boolean;
begin
if args^[0] <> 0 then exit;
nIfs := 1;
Out := False;
Repeat
if not SkipCode then exit;
Case exc.opcode of
(* IF *)
$58 : inc( nIfs );
(* ELSE *)
$1B : out:= nIfs=1;
(* EIF *)
$59 : begin
dec( nIfs );
out:= nIfs=0;
end;
end;
until Out;
end;
(*******************************************)
(* ELSE[] : ELSE *)
(* CodeRange : $1B *)
procedure Ins_ELSE( {%H-}args : PStorage );
var
nIfs : Int;
begin
nIfs := 1;
Repeat
if not SkipCode then exit;
case exc.opcode of
(* IF *)
$58 : inc( nIfs );
(* EIF *)
$59 : dec( nIfs );
end;
until nIfs=0;
end;
(*******************************************)
(* EIF[] : End IF *)
(* CodeRange : $59 *)
procedure Ins_EIF( {%H-}args : PStorage );
begin
(* nothing to do *)
end;
(*******************************************)
(* JROT[] : Jump Relative On True *)
(* CodeRange : $78 *)
procedure Ins_JROT( args : PStorage );
begin
if args^[1] <> 0 then
begin
inc( exc.IP, args^[0] );
exc.step_ins := false;
end;
end;
(*******************************************)
(* JMPR[] : JuMP Relative *)
(* CodeRange : $1C *)
procedure Ins_JMPR( args : PStorage );
begin
inc( exc.IP, args^[0] );
exc.step_ins := false;
end;
(*******************************************)
(* JROF[] : Jump Relative On False *)
(* CodeRange : $79 *)
procedure Ins_JROF( args : PStorage );
begin
if args^[1] = 0 then
begin
inc( exc.IP, args^[0] );
exc.step_ins := false;
end;
end;
(****************************************************************)
(* *)
(* LOGICAL FUNCTIONS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* LT[] : Less Than *)
(* CodeRange : $50 *)
procedure Ins_LT( args : PStorage );
begin
if args^[0] < args^[1] then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* LTEQ[] : Less Than or EQual *)
(* CodeRange : $51 *)
procedure Ins_LTEQ( args : PStorage );
begin
if args^[0] <= args^[1] then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* GT[] : Greater Than *)
(* CodeRange : $52 *)
procedure Ins_GT( args : PStorage );
begin
if args^[0] > args^[1] then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* GTEQ[] : Greater Than or EQual *)
(* CodeRange : $53 *)
procedure Ins_GTEQ( args : PStorage );
begin
if args^[0] >= args^[1] then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* EQ[] : EQual *)
(* CodeRange : $54 *)
procedure Ins_EQ( args : PStorage );
begin
if args^[0] = args^[1] then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* NEQ[] : Not EQual *)
(* CodeRange : $55 *)
procedure Ins_NEQ( args : PStorage );
begin
if args^[0] <> args^[1] then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* ODD[] : Odd *)
(* CodeRange : $56 *)
procedure Ins_ODD( args : PStorage );
begin
if exc.func_round( args^[0], 0 ) and 127 = 64 then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* EVEN[] : Even *)
(* CodeRange : $57 *)
procedure Ins_EVEN( args : PStorage );
begin
if exc.func_round( args^[0], 0 ) and 127 = 0 then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* AND[] : logical AND *)
(* CodeRange : $5A *)
procedure Ins_AND( args : PStorage );
begin
if ( args^[0] <> 0 ) and
( args^[1] <> 0 ) then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* OR[] : logical OR *)
(* CodeRange : $5B *)
procedure Ins_OR( args : PStorage );
begin
if ( args^[0] <> 0 ) or
( args^[1] <> 0 ) then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* NOT[] : logical NOT *)
(* CodeRange : $5C *)
procedure Ins_NOT( args : PStorage );
begin
if args^[0] <> 0 then args^[0] := 0
else args^[0] := 1;
end;
(****************************************************************)
(* *)
(* ARITHMETIC AND MATH INSTRUCTIONS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* ADD[] : ADD *)
(* CodeRange : $60 *)
procedure Ins_ADD( args : PStorage );
begin
inc( args^[0], args^[1] );
end;
(*******************************************)
(* SUB[] : SUBstract *)
(* CodeRange : $61 *)
procedure Ins_SUB( args : PStorage );
begin
dec( args^[0], args^[1] );
end;
(*******************************************)
(* DIV[] : DIVide *)
(* CodeRange : $62 *)
procedure Ins_DIV( args : PStorage );
begin
if args^[1] = 0 then
begin
exc.error := TT_Err_Divide_By_Zero;
exit;
end;
args^[0] := MulDiv_Round( args^[0], 64, args^[1] );
end;
(*******************************************)
(* MUL[] : MULtiply *)
(* CodeRange : $63 *)
procedure Ins_MUL( args : PStorage );
begin
args^[0] := MulDiv_Round( args^[0], args^[1], 64 );
end;
(*******************************************)
(* ABS[] : ABSolute value *)
(* CodeRange : $64 *)
procedure Ins_ABS( args : PStorage );
begin
args^[0] := abs( args^[0] );
end;
(*******************************************)
(* NEG[] : NEGate *)
(* CodeRange : $65 *)
procedure Ins_NEG( args : PStorage );
begin
args^[0] := -args^[0];
end;
(*******************************************)
(* FLOOR[] : FLOOR *)
(* CodeRange : $66 *)
procedure Ins_FLOOR( args : PStorage );
begin
args^[0] := args^[0] and -64;
end;
(*******************************************)
(* CEILING[] : CEILING *)
(* CodeRange : $67 *)
procedure Ins_CEILING( args : PStorage );
begin
args^[0] := ( args^[0]+63 ) and -64;
end;
(*******************************************)
(* MAX[] : MAXimum *)
(* CodeRange : $68 *)
procedure Ins_MAX( args : PStorage );
begin
if args^[1] > args^[0] then args^[0] := args^[1];
end;
(*******************************************)
(* MIN[] : MINimum *)
(* CodeRange : $69 *)
procedure Ins_MIN( args : PStorage );
begin
if args^[1] < args^[0] then args^[0] := args^[1];
end;
(****************************************************************)
(* *)
(* COMPENSATING FOR THE ENGINE CHARACTERISTICS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* ROUND[ab] : ROUND value *)
(* CodeRange : $68-$6B *)
procedure Ins_ROUND( args : PStorage );
begin
args^[0] := exc.func_round( args^[0],
exc.metrics.compensations[ exc.opcode-$68 ] );
end;
(*******************************************)
(* NROUND[ab]: No ROUNDing of value *)
(* CodeRange : $6C-$6F *)
procedure Ins_NROUND( args : PStorage );
begin
args^[0] := Round_None( args^[0],
exc.metrics.compensations[ exc.opcode-$6C ] );
end;
(****************************************************************)
(* *)
(* DEFINING AND USING FUNCTIONS AND INSTRUCTIONS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* FDEF[] : Function DEFinition *)
(* CodeRange : $2C *)
procedure Ins_FDEF( args : PStorage );
var
func : int;
begin
(* check space *)
if exc.numFDefs >= exc.maxFDefs then begin
exc.error := TT_Err_Too_Many_FuncDefs;
exit;
end;
func := Int(args^[0]);
with exc.FDefs^[exc.numFDefs] do
begin
Range := exc.curRange;
Opc := func;
Start := exc.IP+1;
Active := True;
end;
if func > exc.maxFunc then
exc.maxFunc := func;
inc(exc.numFDefs);
(* now skip the whole function definition *)
(* we don't allow nested IDEFS & FDEFs *)
while SkipCode do
case exc.opcode of
$89, (* IDEF *)
$2C : (* FDEF *)
begin
exc.error := TT_Err_Nested_Defs;
exit;
end;
$2D : (* ENDF *)
exit;
end;
end;
(*******************************************)
(* ENDF[] : END Function definition *)
(* CodeRange : $2D *)
procedure Ins_ENDF( {%H-}args : PStorage );
begin
if exc.callTop <= 0 then (* We encountered an ENDF without a call *)
begin
exc.error := TT_Err_ENDF_in_Exec_Stream;
exit;
end;
dec( exc.CallTop );
with exc.Callstack^[exc.CallTop] do
begin
dec( Cur_Count );
exc.step_ins := false;
if Cur_Count > 0 then
begin
(* Loop the current function *)
inc( exc.callTop );
exc.IP := Cur_Restart;
end
else
(* exit the current call frame *)
(* NOTE : When the last intruction of a program *)
(* is a CALL or LOOPCALL, the return address *)
(* is always out of the code range. This is *)
(* valid address, and is why we do not test *)
(* the result of Goto_CodeRange here !! *)
Goto_CodeRange( Caller_Range, Caller_IP )
end;
end;
(*******************************************)
(* CALL[] : CALL function *)
(* CodeRange : $2B *)
procedure Ins_CALL( args : PStorage );
var
ii, nn : Int;
def : PDefRecord;
label
Fail;
begin
(* First of all, check index *)
if (args^[0] < 0) or (args^[0] > exc.maxFunc) then
goto Fail;
(* Except for some old Apple fonts, all functions in a TrueType *)
(* fonts are defined in increasing order, starting from 0. *)
(* *)
(* This mean that, normally, we have : *)
(* *)
(* exc.maxFunc+1 = exc.numFDefs *)
(* exc.FDefs[n].opc = n for n in 0..exc.maxFunc *)
(* *)
nn := Int(args^[0]);
def := @exc.FDefs^[nn];
if ( exc.maxFunc+1 <> exc.numFDefs ) or ( def^.opc <> nn ) then begin
(* lookup the FDefs table *)
ii := 0;
def := @exc.FDefs^[0];
while (ii < exc.numFDefs) and (def^.opc <> nn) do begin
inc(ii);
inc(def);
end;
(* Fail if the function isn't listed *)
if ii >= exc.numFDefs then
goto Fail;
end;
(* check that the function is active *)
if not def^.active then
goto Fail;
(* check call stack *)
if exc.callTop >= exc.callSize then
begin
exc.error := TT_Err_Stack_Overflow;
exit;
end;
with exc.callstack^[exc.callTop] do
begin
Caller_Range := exc.curRange;
Caller_IP := exc.IP+1;
Cur_Count := 1;
Cur_Restart := def^.Start;
end;
inc( exc.CallTop );
with def^ do Goto_CodeRange( Range, Start );
exc.step_ins := false;
exit;
Fail:
exc.error := TT_Err_Invalid_Reference;
exit;
end;
(*******************************************)
(* LOOPCALL[]: LOOP and CALL function *)
(* CodeRange : $2A *)
procedure Ins_LOOPCALL( args : PStorage );
begin
if ( args^[1] < 0 ) or ( args^[1] >= exc.numFDefs ) or
( not exc.FDefs^[args^[1]].Active ) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
if exc.callTop >= exc.callSize then
begin
exc.error := TT_Err_Stack_Overflow;
exit;
end;
if args^[0] > 0 then
begin
with exc.callstack^[exc.callTop] do
begin
Caller_Range := exc.curRange;
Caller_IP := exc.IP+1;
Cur_Count := args^[0];
Cur_Restart := exc.FDefs^[args^[1]].Start;
end;
inc( exc.CallTop );
with exc.FDefs^[args^[1]] do Goto_CodeRange( Range, Start );
exc.step_ins := false;
end;
end;
(*******************************************)
(* IDEF[] : Instruction DEFinition *)
(* CodeRange : $89 *)
procedure Ins_IDEF( args : PStorage );
var
A : Int;
begin
A := 0;
while ( A < exc.numIDefs ) do
with exc.IDefs^[A] do
begin
if not Active then
begin
Opc := args^[0];
Start := exc.IP+1;
Range := exc.curRange;
Active := True;
A := exc.numIDefs;
(* now skip the whole function definition *)
(* we don't allow nested IDEFS & FDEFs *)
while SkipCode do
case exc.opcode of
$89, (* IDEF *)
$2C : (* FDEF *)
begin
exc.error := TT_Err_Nested_Defs;
exit;
end;
$2D : (* ENDF *)
exit;
end;
end
else
inc( A );
end;
end;
(****************************************************************)
(* *)
(* PUSHING DATA ONTO THE INTERPRETER STACK *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* NPUSHB[] : PUSH N Bytes *)
(* CodeRange : $40 *)
procedure Ins_NPUSHB( args : PStorage );
var
L, K : Long;
begin
L := exc.code^[exc.IP+1];
if exc.top + L > exc.stackSize then
begin
exc.error := TT_Err_Stack_Overflow;
exit;
end;
for K := 1 to L do
args^[k-1] := exc.code^[exc.IP+1+k];
inc( exc.new_top, L );
end;
(*******************************************)
(* NPUSHW[] : PUSH N Words *)
(* CodeRange : $41 *)
procedure Ins_NPUSHW( args : PStorage );
var
L, K : Long;
begin
L := exc.code^[exc.IP+1];
if exc.top + L > exc.stackSize then
begin
exc.error := TT_Err_Stack_Overflow;
exit;
end;
inc( exc.IP, 2 );
for K := 1 to L do
args^[k-1] := GetShort;
exc.step_ins := false;
inc( exc.new_top, L );
end;
(*******************************************)
(* PUSHB[abc]: PUSH Bytes *)
(* CodeRange : $B0-$B7 *)
procedure Ins_PUSHB( args : PStorage );
var
L, K : Long;
begin
L := exc.opcode - $B0+1;
if exc.top + L >= exc.stackSize then
begin
exc.error := TT_Err_Stack_Overflow;
exit;
end;
for k := 1 to L do
args^[k-1] := exc.code^[exc.ip+k];
end;
(*******************************************)
(* PUSHW[abc]: PUSH Words *)
(* CodeRange : $B8-$BF *)
procedure Ins_PUSHW( args : PStorage );
var
L, K : Long;
begin
L := exc.opcode - $B8+1;
if exc.top + L >= exc.stackSize then
begin
exc.error := TT_Err_Stack_Overflow;
exit;
end;
inc( exc.IP );
for k := 1 to L do
args^[k-1] := GetShort;
exc.step_ins := false;
end;
(****************************************************************)
(* *)
(* MANAGING THE STORAGE AREA *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* RS[] : Read Store *)
(* CodeRange : $43 *)
procedure Ins_RS( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= exc.storeSize) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
args^[0] := exc.storage^[args^[0]];
end;
(*******************************************)
(* WS[] : Write Store *)
(* CodeRange : $42 *)
procedure Ins_WS( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= exc.storeSize) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
exc.storage^[args^[0]] := args^[1];
end;
(*******************************************)
(* WCVTP[] : Write CVT in Pixel units *)
(* CodeRange : $44 *)
procedure Ins_WCVTP( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= exc.cvtSize) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
exc.func_write_cvt( args^[0], args^[1] );
end;
(*******************************************)
(* WCVTF[] : Write CVT in FUnits *)
(* CodeRange : $70 *)
procedure Ins_WCVTF( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= exc.cvtSize) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
exc.cvt^[args^[0]] := Scale_Pixels(args^[1]);
end;
(*******************************************)
(* RCVT[] : Read CVT *)
(* CodeRange : $45 *)
procedure Ins_RCVT( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= exc.cvtSize) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
args^[0] := exc.func_read_cvt(args^[0]);
end;
(****************************************************************)
(* *)
(* MANAGING THE GRAPHICS STATE *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* SVTCA[a] : Set F and P vectors to axis *)
(* CodeRange : $00-$01 *)
procedure Ins_SVTCA( {%H-}args : PStorage );
var A, B : Short;
begin
case (exc.opcode and 1) of
0 : A := $0000;
1 : A := $4000;
end;
B := A xor $4000;
exc.GS.freeVector.x := A;
exc.GS.projVector.x := A;
exc.GS.dualVector.x := A;
exc.GS.freeVector.y := B;
exc.GS.projVector.y := B;
exc.GS.dualVector.y := B;
Compute_Funcs;
end;
(*******************************************)
(* SPVTCA[a] : Set PVector to Axis *)
(* CodeRange : $02-$03 *)
procedure Ins_SPVTCA( {%H-}args : PStorage );
var A, B : Short;
begin
case (exc.opcode and 1) of
0 : A := $0000;
1 : A := $4000;
end;
B := A xor $4000;
exc.GS.projVector.x := A;
exc.GS.dualVector.x := A;
exc.GS.projVector.y := B;
exc.GS.dualVector.y := B;
Compute_Funcs;
end;
(*******************************************)
(* SFVTCA[a] : Set FVector to Axis *)
(* CodeRange : $04-$05 *)
procedure Ins_SFVTCA( {%H-}args : PStorage );
var A, B : Short;
begin
case (exc.opcode and 1) of
0 : A := $0000;
1 : A := $4000;
end;
B := A xor $4000;
exc.GS.freeVector.x := A;
exc.GS.freeVector.y := B;
Compute_Funcs;
end;
function Ins_SxVTL( aIdx1 : Int;
aIdx2 : Int;
aOpc : Int;
var Vec : TT_UnitVector ) : boolean;
var
A, B, C : Long;
begin
Ins_SxVTL := False;
with exc do
begin
if (aIdx2 >= zp1.n_points) or (aIdx1 >= zp2.n_points) then
begin
Error := TT_Err_Invalid_Reference;
exit;
end;
with zp1.Cur^[aIdx2] do
begin
A := x;
B := y;
end;
with zp2.Cur^[aIdx1] do
begin
dec( A, x );
dec( B, y );
end;
if aOpc and 1 <> 0 then
begin
C := B; (* CounterClockwise rotation *)
B := A;
A := -C;
end;
if not Normalize( A, B, Vec ) then
begin
exc.error := TT_Err_Ok;
Vec.x := $4000;
Vec.y := $0000;
end;
Ins_SxVTL := True;
end;
end;
(*******************************************)
(* SPVTL[a] : Set PVector to Line *)
(* CodeRange : $06-$07 *)
procedure Ins_SPVTL( args : PStorage );
begin
if not INS_SxVTL( args^[1],
args^[0],
exc.opcode,
exc.GS.projVector ) then exit;
exc.GS.dualVector := exc.GS.projVector;
Compute_Funcs;
end;
(*******************************************)
(* SFVTL[a] : Set FVector to Line *)
(* CodeRange : $08-$09 *)
procedure Ins_SFVTL( args : PStorage );
begin
if not INS_SxVTL( args^[1],
args^[0],
exc.opcode,
exc.GS.freeVector ) then exit;
Compute_Funcs;
end;
(*******************************************)
(* SFVTPV[] : Set FVector to PVector *)
(* CodeRange : $0E *)
procedure Ins_SFVTPV( {%H-}args : PStorage );
begin
exc.GS.freeVector := exc.GS.projVector;
Compute_Funcs;
end;
(*******************************************)
(* SDPVTL[a] : Set Dual PVector to Line *)
(* CodeRange : $86-$87 *)
procedure Ins_SDPVTL( args : PStorage );
var
A, B, C : Long;
p1, p2 : Int;
begin
p1 := args^[1];
p2 := args^[0];
if (args^[0] < 0) or (args^[0] >= exc.zp1.n_points) or
(args^[1] < 0) or (args^[1] >= exc.zp2.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
A := exc.zp1.org^[p2].x - exc.zp2.org^[p1].x;
B := exc.zp1.org^[p2].y - exc.zp2.org^[p1].y;
if exc.opcode and 1 <> 0 then
begin
C := B; (* CounterClockwise rotation *)
B := A;
A := -C;
end;
Normalize( A, B, exc.GS.dualVector );
A := exc.zp1.cur^[p2].x - exc.zp2.cur^[p1].x;
B := exc.zp1.cur^[p2].y - exc.zp2.cur^[p1].y;
if exc.opcode and 1 <> 0 then
begin
C := B; (* CounterClockwise rotation *)
B := A;
A := -C;
end;
Normalize( A, B, exc.GS.projVector );
Compute_Funcs;
exc.error := TT_Err_Ok;
end;
(*******************************************)
(* SPVFS[] : Set PVector From Stack *)
(* CodeRange : $0A *)
procedure Ins_SPVFS( args : PStorage );
var
S : Short;
X, Y : Long;
begin
S := args^[1]; Y := S; (* type conversion; extends sign *)
S := args^[0]; X := S; (* type conversion; extends sign *)
if not Normalize( X, Y, exc.GS.projVector ) then exit;
exc.GS.dualVector := exc.GS.projVector;
Compute_Funcs;
end;
(*******************************************)
(* SFVFS[] : Set FVector From Stack *)
(* CodeRange : $0B *)
procedure Ins_SFVFS( args : PStorage );
var
S : Short;
X, Y : Long;
begin
S := args^[1]; Y := S; (* type conversion; extends sign *)
S := args^[0]; X := S; (* type conversion; extends sign *)
if not Normalize( X, Y, exc.GS.freeVector ) then exit;
Compute_Funcs;
end;
(*******************************************)
(* GPV[] : Get Projection Vector *)
(* CodeRange : $0C *)
procedure Ins_GPV( args : PStorage );
begin
args^[0] := exc.GS.projVector.x;
args^[1] := exc.GS.projVector.y;
end;
(*******************************************)
(* GFV[] : Get Freedom Vector *)
(* CodeRange : $0D *)
procedure Ins_GFV( args : PStorage );
begin
args^[0] := exc.GS.freeVector.x;
args^[1] := exc.GS.freeVector.y;
end;
(*******************************************)
(* SRP0[] : Set Reference Point 0 *)
(* CodeRange : $10 *)
procedure Ins_SRP0( args : PStorage );
begin
exc.GS.rp0 := args^[0];
end;
(*******************************************)
(* SRP1[] : Set Reference Point 1 *)
(* CodeRange : $11 *)
procedure Ins_SRP1( args : PStorage );
begin
exc.GS.rp1 := args^[0];
end;
(*******************************************)
(* SRP2[] : Set Reference Point 2 *)
(* CodeRange : $12 *)
procedure Ins_SRP2( args : PStorage );
begin
exc.GS.rp2 := args^[0];
end;
(*******************************************)
(* SZP0[] : Set Zone Pointer 0 *)
(* CodeRange : $13 *)
procedure Ins_SZP0( args : PStorage );
begin
case args^[0] of
0 : exc.zp0 := exc.Twilight;
1 : exc.zp0 := exc.Pts;
else
exc.error := TT_Err_Invalid_Reference;
exit;
end;
exc.GS.gep0 := args^[0];
end;
(*******************************************)
(* SZP1[] : Set Zone Pointer 1 *)
(* CodeRange : $14 *)
procedure Ins_SZP1( args : PStorage );
begin
case args^[0] of
0 : exc.zp1 := exc.Twilight;
1 : exc.zp1 := exc.Pts;
else
exc.error := TT_Err_Invalid_Reference;
exit;
end;
exc.GS.gep1 := args^[0];
end;
(*******************************************)
(* SZP2[] : Set Zone Pointer 2 *)
(* CodeRange : $15 *)
procedure Ins_SZP2( args : PStorage );
begin
case args^[0] of
0 : exc.zp2 := exc.Twilight;
1 : exc.zp2 := exc.Pts;
else
exc.error := TT_Err_Invalid_Reference;
exit;
end;
exc.GS.gep2 := args^[0];
end;
(*******************************************)
(* SZPS[] : Set Zone Pointers *)
(* CodeRange : $16 *)
procedure Ins_SZPS( args : PStorage );
begin
case args^[0] of
0 : exc.zp0 := exc.Twilight;
1 : exc.zp0 := exc.Pts;
else
exc.error := TT_Err_Invalid_Reference;
exit;
end;
exc.zp1 := exc.zp0;
exc.zp2 := exc.zp0;
exc.GS.gep0 := args^[0];
exc.GS.gep1 := args^[0];
exc.GS.gep2 := args^[0];
end;
(*******************************************)
(* RTHG[] : Round To Half Grid *)
(* CodeRange : $19 *)
procedure Ins_RTHG( {%H-}args : PStorage );
begin
exc.GS.round_state := TT_Round_To_Half_Grid;
{$IFDEF FPC}
exc.func_round := @Round_To_Half_Grid;
{$ELSE}
exc.func_round := Round_To_Half_Grid;
{$ENDIF}
end;
(*******************************************)
(* RTG[] : Round To Grid *)
(* CodeRange : $18 *)
procedure Ins_RTG( {%H-}args : PStorage );
begin
exc.GS.round_state := TT_Round_To_Grid;
{$IFDEF FPC}
exc.func_round := @Round_To_Grid;
{$ELSE}
exc.func_round := Round_To_Grid;
{$ENDIF}
end;
(*******************************************)
(* RTDG[] : Round To Double Grid *)
(* CodeRange : $3D *)
procedure Ins_RTDG( {%H-}args : PStorage );
begin
exc.GS.round_state := TT_Round_To_Double_Grid;
{$IFDEF FPC}
exc.func_round := @Round_To_Double_Grid;
{$ELSE}
exc.func_round := Round_To_Double_Grid;
{$ENDIF}
end;
(*******************************************)
(* RUTG[] : Round Up To Grid *)
(* CodeRange : $7C *)
procedure Ins_RUTG( {%H-}args : PStorage );
begin
exc.GS.round_state := TT_Round_Up_To_Grid;
{$IFDEF FPC}
exc.func_round := @Round_Up_To_Grid;
{$ELSE}
exc.func_round := Round_Up_To_Grid;
{$ENDIF}
end;
(*******************************************)
(* RDTG[] : Round Down To Grid *)
(* CodeRange : $7D *)
procedure Ins_RDTG( {%H-}args : PStorage );
begin
exc.GS.round_state := TT_Round_Down_To_Grid;
{$IFDEF FPC}
exc.func_round := @Round_Down_To_Grid;
{$ELSE}
exc.func_round := Round_Down_To_Grid;
{$ENDIF}
end;
(*******************************************)
(* ROFF[] : Round OFF *)
(* CodeRange : $7A *)
procedure Ins_ROFF( {%H-}args : PStorage );
begin
exc.GS.round_state := TT_Round_Off;
{$IFDEF FPC}
exc.func_round := @Round_None;
{$ELSE}
exc.func_round := Round_None;
{$ENDIF}
end;
(*******************************************)
(* SROUND[] : Super ROUND *)
(* CodeRange : $76 *)
procedure Ins_SROUND( args : PStorage );
begin
SetSuperRound( $4000, args^[0] );
exc.GS.round_state := TT_Round_Super;
{$IFDEF FPC}
exc.func_round := @Round_Super;
{$ELSE}
exc.func_round := Round_Super;
{$ENDIF}
end;
(*******************************************)
(* S45ROUND[]: Super ROUND 45 degrees *)
(* CodeRange : $77 *)
procedure Ins_S45ROUND( args : PStorage );
begin
SetSuperRound( $2D41, args^[0] );
exc.GS.round_state := TT_Round_Super_45;
{$IFDEF FPC}
exc.func_round := @Round_Super_45;
{$ELSE}
exc.func_round := Round_Super_45;
{$ENDIF}
end;
(*******************************************)
(* SLOOP[] : Set LOOP variable *)
(* CodeRange : $17 *)
procedure Ins_SLOOP( args : PStorage );
begin
exc.GS.Loop := args^[0];
end;
(*******************************************)
(* SMD[] : Set Minimum Distance *)
(* CodeRange : $1A *)
procedure Ins_SMD( args : PStorage );
begin
exc.GS.minimum_distance := args^[0];
end;
(*******************************************)
(* INSTCTRL[]: INSTruction ConTRol *)
(* CodeRange : $8e *)
procedure Ins_INSTCTRL( args : PStorage );
var
K, L : Int;
begin
K := args^[1];
L := args^[0];
if ( K < 1 ) or ( K > 2 ) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
if L <> 0 then L := K;
exc.GS.instruct_control := ( exc.GS.instruct_control and not K ) or L;
end;
(*******************************************)
(* SCANCTRL[]: SCAN ConTRol *)
(* CodeRange : $85 *)
procedure Ins_SCANCTRL( args : PStorage );
var
A : Int;
begin
(* Get Threshold *)
A := args^[0] and $FF;
if A = $FF then
exc.GS.scan_Control := True
else
if A = 0 then
exc.GS.scan_Control := False
else
begin
A := A * 64;
(* XXX TODO : Add rotation and stretch cases *)
if ( args^[0] and $100 <> 0 ) and
( exc.metrics.pointSize <= A ) then exc.GS.scan_Control := True;
if ( args^[0] and $200 <> 0 ) and
( false ) then exc.GS.scan_Control := True;
if ( args^[0] and $400 <> 0 ) and
( false ) then exc.GS.scan_Control := True;
if ( args^[0] and $800 <> 0 ) and
( exc.metrics.pointSize > A ) then exc.GS.scan_Control := False;
if ( args^[0] and $1000 <> 0 ) and
( not False ) then exc.GS.scan_Control := False;
if ( args^[0] and $2000 <> 0 ) and
( not False ) then exc.GS.scan_Control := False;
end;
end;
(*******************************************)
(* SCANTYPE[]: SCAN TYPE *)
(* CodeRange : $8D *)
procedure Ins_SCANTYPE( args : PStorage );
begin
(* For compatibility with future enhancements, *)
(* we must ignore new modes *)
if (args^[0] >= 0 ) and (args^[0] <= 5) then
begin
if args^[0] = 3 then args^[0] := 2;
exc.GS.scan_type := args^[0];
end;
end;
(**********************************************)
(* SCVTCI[] : Set Control Value Table Cut In *)
(* CodeRange : $1D *)
procedure Ins_SCVTCI( args : PStorage );
begin
exc.GS.control_value_cutin := args^[0];
end;
(**********************************************)
(* SSWCI[] : Set Single Width Cut In *)
(* CodeRange : $1E *)
procedure Ins_SSWCI( args : PStorage );
begin
exc.GS.single_width_cutin := args^[0];
end;
(**********************************************)
(* SSW[] : Set Single Width *)
(* CodeRange : $1F *)
procedure Ins_SSW( args : PStorage );
begin
exc.GS.single_width_value := args^[0] div $400;
end;
(**********************************************)
(* FLIPON[] : Set Auto_flip to On *)
(* CodeRange : $4D *)
procedure Ins_FLIPON( {%H-}args : PStorage );
begin
exc.GS.auto_flip := True;
end;
(**********************************************)
(* FLIPOFF[] : Set Auto_flip to Off *)
(* CodeRange : $4E *)
procedure Ins_FLIPOFF( {%H-}args : PStorage );
begin
exc.GS.auto_flip := False;
end;
(**********************************************)
(* SANGW[] : Set Angle Weigth *)
(* CodeRange : $7E *)
procedure Ins_SANGW( {%H-}args : PStorage );
begin
(* instruction not supported anymore *)
end;
(**********************************************)
(* SDB[] : Set Delta Base *)
(* CodeRange : $5E *)
procedure Ins_SDB( args : PStorage );
begin
exc.GS.delta_base := args^[0]
end;
(**********************************************)
(* SDS[] : Set Delta Shift *)
(* CodeRange : $5F *)
procedure Ins_SDS( args : PStorage );
begin
exc.GS.delta_shift := args^[0]
end;
(**********************************************)
(* GC[a] : Get Coordinate projected onto *)
(* CodeRange : $46-$47 *)
(* BULLSHIT : Measures from the original glyph must to be taken *)
(* along the dual projection vector !! *)
procedure Ins_GC( args : PStorage );
var
L : Int;
begin
L := args^[0];
if (L < 0) or (L >= exc.zp2.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
case exc.opcode and 1 of
0 : L := exc.func_project ( exc.zp2.cur^[L], Null_Vector );
1 : L := exc.func_dualProj( exc.zp2.org^[L], Null_Vector );
end;
args^[0] := L;
end;
(**********************************************)
(* SCFS[] : Set Coordinate From Stack *)
(* CodeRange : $48 *)
(* *)
(* Formule : *)
(* *)
(* OA := OA + ( value - OA.p )/( f.p ) x f *)
(* *)
procedure Ins_SCFS( args : PStorage );
var
K, L : Int;
begin
L := args^[0];
if (args^[0] < 0) or (args^[0] >= exc.zp2.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
K := exc.func_project( exc.zp2.cur^[L], Null_Vector );
exc.func_move( @exc.zp2, L, args^[1] - K );
(* not part of the specs, but here for safety *)
if exc.GS.gep2 = 0 then
exc.zp2.org^[L] := exc.zp2.cur^[L];
end;
(**********************************************)
(* MD[a] : Measure Distance *)
(* CodeRange : $49-$4A *)
(* BULLSHIT : Measure taken in the original glyph must be along *)
(* the dual projection vector *)
(* Second BULLSHIT : Flag attributions are inverted !! *)
(* 0 => measure distance in original outline *)
(* 1 => measure distance in grid-fitted outline *)
procedure Ins_MD( args : PStorage );
var
K, L : Int;
D : TT_F26dot6;
begin
K := args^[1];
L := args^[0];
if (args^[0] < 0) or (args^[0] >= exc.zp0.n_points) or
(args^[1] < 0) or (args^[1] >= exc.zp1.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
case exc.opcode and 1 of
0 : D := exc.func_dualProj( exc.zp0.org^[L], exc.zp1.org^[K] );
1 : D := exc.func_project ( exc.zp0.cur^[L], exc.zp1.cur^[K] );
end;
args^[0] := D;
end;
(**********************************************)
(* MPPEM[] : Measure Pixel Per EM *)
(* CodeRange : $4B *)
procedure Ins_MPPEM( args : PStorage );
begin
args^[0] := Get_Ppem;
end;
(**********************************************)
(* MPS[] : Measure PointSize *)
(* CodeRange : $4C *)
procedure Ins_MPS( args : PStorage );
begin
args^[0] := exc.metrics.pointSize;
end;
(****************************************************************)
(* *)
(* MANAGING OUTLINES *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(**********************************************)
(* FLIPPT[] : FLIP PoinT *)
(* CodeRange : $80 *)
procedure Ins_FLIPPT( {%H-}args : PStorage );
var
point : Int;
begin
if exc.top < exc.GS.loop then
begin
exc.error := TT_Err_Too_Few_Arguments;
exit;
end;
while exc.GS.loop > 0 do
begin
dec( exc.args );
point := exc.stack^[ exc.args ];
if (point < 0) or (point >= exc.pts.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
exc.pts.flags^[point] := exc.pts.flags^[point] xor TT_Flag_On_Curve;
dec( exc.GS.loop );
end;
exc.GS.loop := 1;
exc.new_top := exc.args;
end;
(**********************************************)
(* FLIPRGON[]: FLIP RanGe ON *)
(* CodeRange : $81 *)
procedure Ins_FLIPRGON( args : PStorage );
var
I, K, L : Int;
begin
K := args^[1];
L := args^[0];
if (K < 0) or (K >= exc.pts.n_points) or
(L < 0) or (L >= exc.pts.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
for I := L to K do
exc.pts.flags^[I] := exc.pts.flags^[I] or TT_Flag_On_Curve;
end;
(**********************************************)
(* FLIPRGOFF : FLIP RanGe OFF *)
(* CodeRange : $82 *)
procedure Ins_FLIPRGOFF( args : PStorage );
var
I, K, L : Int;
begin
K := args^[1];
L := args^[0];
if (K < 0) or (K >= exc.pts.n_points) or
(L < 0) or (L >= exc.pts.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
for I := L to K do
exc.pts.flags^[I] := exc.pts.flags^[I] and not TT_Flag_On_Curve;
end;
function Compute_Point_Displacement( out x : TT_F26dot6;
out y : TT_F26dot6;
out zone : PGlyph_Zone;
out refp : Int ) : TError;
var
zp : PGlyph_Zone;
p : Int;
d : TT_F26dot6;
begin
Compute_Point_Displacement := Success;
case exc.opcode and 1 of
0 : begin zp := @exc.zp1; p := exc.GS.rp2; end;
1 : begin zp := @exc.zp0; p := exc.GS.rp1; end;
end;
if (p < 0) or (p >= zp^.n_points) then
begin
exc.error := TT_Err_Invalid_Displacement;
Compute_Point_Displacement := Failure;
exit;
end;
zone := zp;
refp := p;
d := exc.func_project( zp^.cur^[p], zp^.org^[p] );
x := MulDiv_Round( d, Long(exc.GS.freeVector.x)*$10000, exc.F_dot_P );
y := MulDiv_Round( d, Long(exc.GS.freeVector.y)*$10000, exc.F_dot_P );
end;
procedure Move_Zp2_Point( point : Int;
dx : TT_F26dot6;
dy : TT_F26dot6 );
begin
if exc.GS.freeVector.x <> 0 then
begin
inc( exc.zp2.cur^[point].x, dx );
exc.zp2.flags^[point] := exc.zp2.flags^[point] or TT_Flag_Touched_X;
end;
if exc.GS.freeVector.y <> 0 then
begin
inc( exc.zp2.cur^[point].y, dy );
exc.zp2.flags^[point] := exc.zp2.flags^[point] or TT_Flag_Touched_Y;
end;
end;
(**********************************************)
(* SHP[a] : SHift Point by the last point *)
(* CodeRange : $32-33 *)
procedure Ins_SHP( {%H-}args : PStorage );
var
zp : PGlyph_Zone;
refp : Int;
dx : TT_F26dot6;
dy : TT_F26dot6;
point: Int;
begin
if Compute_Point_Displacement( dx, dy, zp, refp ) then
exit;
if exc.top < exc.GS.loop then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
while exc.GS.loop > 0 do
begin
dec( exc.args );
point := exc.stack^[ exc.args ];
if (point < 0) or (point >= exc.zp2.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
Move_Zp2_Point( point, dx, dy );
dec( exc.GS.loop );
end;
exc.GS.loop := 1;
exc.new_top := exc.args;
end;
(**********************************************)
(* SHC[a] : SHift Contour *)
(* CodeRange : $34-35 *)
procedure Ins_SHC( args : PStorage );
var
zp : PGlyph_Zone;
refp : Int;
dx : TT_F26dot6;
dy : TT_F26dot6;
contour, i : Int;
first_point, last_point : Int;
begin
contour := args^[0];
if (args^[0] < 0) or (args^[0] >= exc.pts.n_contours ) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
if Compute_Point_Displacement( dx, dy, zp, refp ) then
exit;
if contour = 0 then first_point := 0 else
first_point := exc.pts.conEnds^[contour-1]+1;
last_point := exc.pts.conEnds^[contour];
for i := first_point to last_point do
begin
if (zp^.cur <> exc.zp2.cur) or
(refp <> i ) then
Move_Zp2_Point( i, dx, dy );
end;
end;
(**********************************************)
(* SHZ[a] : SHift Zone *)
(* CodeRange : $36-37 *)
procedure Ins_SHZ( args : PStorage );
var
zp : PGlyph_Zone;
refp : Int;
dx : TT_F26dot6;
dy : TT_F26dot6;
i : Int;
last_point : Int;
begin
//zone := args^[0];
if (args^[0] < 0) or (args^[0] > 1) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
if Compute_Point_Displacement( dx, dy, zp, refp ) then
exit;
last_point := zp^.n_points-1;
for i := 0 to last_point do
begin
if (zp^.cur <> exc.zp2.cur) or
(refp <> i ) then
Move_Zp2_Point( i, dx, dy );
end;
end;
(**********************************************)
(* SHPIX[] : SHift points by a PIXel amount *)
(* CodeRange : $38 *)
procedure Ins_SHPIX( args : PStorage );
var
dx : TT_F26dot6;
dy : TT_F26dot6;
point: Int;
begin
if exc.top < exc.GS.loop then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
dx := MulDiv_Round( args^[0],
exc.GS.freeVector.x,
$4000 );
dy := MulDiv_Round( args^[0],
exc.GS.freeVector.y,
$4000 );
while exc.GS.loop > 0 do
begin
dec( exc.args );
point := exc.stack^[ exc.args ];
if (point < 0) or (point >= exc.zp2.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
Move_Zp2_Point( point, dx, dy );
dec( exc.GS.loop );
end;
exc.GS.loop := 1;
exc.new_top := exc.args;
end;
(**********************************************)
(* MSIRP[a] : Move Stack Indirect Relative *)
(* CodeRange : $3A-$3B *)
procedure Ins_MSIRP( args : PStorage );
var
point : Int;
distance : TT_F26dot6;
begin
point := args^[0];
if (args^[0] < 0) or (args^[0] >= exc.zp1.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
(* XXX : UNDOCUMENTED - Twilight Zone *)
(* Again, one stupid undocumented feature found in the *)
(* twilight zone. What did these guys had in mind when *)
(* they wrote the spec ? There _must_ be another *)
(* specification than the published one !! #@%$& !! *)
if exc.GS.gep0 = 0 then (* if in twilight zone *)
begin
exc.zp1.org^[point] := exc.zp0.org^[exc.GS.rp0];
exc.zp1.cur^[point] := exc.zp1.org^[point];
end;
distance := exc.func_project( exc.zp1.cur^[point],
exc.zp0.cur^[exc.GS.rp0] );
exc.func_move( @exc.zp1, point, args^[1] - distance );
exc.GS.rp1 := exc.GS.rp0;
exc.GS.rp2 := point;
if exc.opcode and 1 <> 0 then exc.GS.rp0 := point;
end;
(**********************************************)
(* MDAP[a] : Move Direct Absolute Point *)
(* CodeRange : $2E-$2F *)
procedure Ins_MDAP( args : PStorage );
var
point : Int;
cur_dist : TT_F26dot6;
distance : TT_F26dot6;
begin
point := args^[0];
if (args^[0] < 0) or (args^[0] >= exc.zp0.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
(* XXXX Is there some undocumented feature while in the *)
(* twilight zone ?? *)
if exc.opcode and 1 <> 0 then
begin
cur_dist := exc.func_project( exc.zp0.cur^[point], Null_Vector );
distance := exc.func_round( cur_dist,
exc.metrics.compensations[0] ) -
cur_dist;
end
else
distance := 0;
exc.func_move( @exc.zp0, point, distance );
exc.GS.rp0 := point;
exc.GS.rp1 := point;
end;
(**********************************************)
(* MIAP[a] : Move Indirect Absolute Point *)
(* CodeRange : $3E-$3F *)
procedure Ins_MIAP( args : PStorage );
var
cvtEntry : Int;
point : Int;
distance : TT_F26dot6;
org_dist : TT_F26dot6;
begin
cvtEntry := args^[1];
point := args^[0];
if (args^[0] < 0) or (args^[0] >= exc.zp0.n_points ) or
(args^[1] < 0) or (args^[1] >= exc.cvtSize) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
(* Undocumented : *)
(* *)
(* The behaviour of an MIAP instruction is quite *)
(* different when used in the twilight zone^. *)
(* *)
(* First, no control value cutin test is performed *)
(* as it would fail anyway. Second, the original *)
(* point, i.e. (org_x,org_y) of zp0.point, is set *)
(* to the absolute, unrounded, distance found in *)
(* the CVT. *)
(* *)
(* This is used in the CVT programs of the Microsoft *)
(* fonts Arial, Times, etc.., in order to re-adjust *)
(* some key font heights. It allows the use of the *)
(* IP instruction in the twilight zone, which *)
(* otherwise would be "illegal" per se the specs :) *)
(* *)
(* We implement it with a special sequence for the *)
(* twilight zone. This is a bad hack, but it seems *)
(* to work.. *)
(* - David *)
distance := exc.func_read_cvt(cvtEntry);
if exc.GS.gep0 = 0 then (* If in twilight zone *)
begin
exc.zp0.org^[point].y := MulDiv_Round( exc.GS.freeVector.x,
distance,
$4000 );
exc.zp0.org^[point].y := MulDiv_Round( exc.GS.freeVector.y,
distance,
$4000 );
exc.zp0.cur^[point] := exc.zp0.org^[point];
end;
org_dist := exc.func_project( exc.zp0.cur^[point], Null_Vector );
if exc.opcode and 1 <> 0 then (* rounding and control cutin flag *)
begin
if abs( distance-org_dist ) > exc.GS.control_value_cutin then
distance := org_dist;
distance := exc.func_round( distance,
exc.metrics.compensations[0] );
end;
exc.func_move( @exc.zp0, point, distance - org_dist );
exc.GS.rp0 := point;
exc.GS.rp1 := point;
end;
(**********************************************)
(* MDRP[abcde] : Move Direct Relative Point *)
(* CodeRange : $C0-$DF *)
procedure Ins_MDRP( args : PStorage );
var
point : Int;
distance : TT_F26dot6;
org_dist : TT_F26dot6;
begin
point := args^[0];
if (args^[0] < 0) or (args^[0] >= exc.zp1.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
(* XXXX Is there some undocumented feature while in the *)
(* twilight zone ?? *)
org_dist := exc.func_dualProj( exc.zp1.org^[point],
exc.zp0.org^[exc.GS.rp0] );
(* single width cutin test *)
if abs(org_dist) < exc.GS.single_width_cutin then
if org_dist >= 0 then org_dist := exc.GS.single_width_value
else org_dist := -exc.GS.single_width_value;
(* round flag *)
if exc.opcode and 4 <> 0 then
distance := exc.func_round( org_dist,
exc.metrics.compensations[ exc.opcode and 3 ] )
else
distance := Round_None( org_dist,
exc.metrics.compensations[ exc.opcode and 3 ] );
(* minimum distance flag *)
if exc.opcode and 8 <> 0 then
begin
if org_dist >= 0 then
if distance < exc.GS.minimum_distance then
distance := exc.GS.minimum_distance
else
else
if distance > -exc.GS.minimum_distance then
distance := -exc.GS.minimum_distance;
end;
(* now move the point *)
org_dist := exc.func_project( exc.zp1.cur^[point],
exc.zp0.cur^[exc.GS.rp0] );
exc.func_move( @exc.zp1, point, distance - org_dist );
exc.GS.rp1 := exc.GS.rp0;
exc.GS.rp2 := point;
if exc.opcode and 16 <> 0 then exc.GS.rp0 := point;
end;
(**********************************************)
(* MIRP[abcde] : Move Indirect Relative Point *)
(* CodeRange : $E0-$FF *)
procedure Ins_MIRP( args : PStorage );
var
point : Int;
cvtEntry : Int;
cvt_dist : TT_F26dot6;
distance : TT_F26dot6;
cur_dist : TT_F26dot6;
org_dist : TT_F26dot6;
begin
point := args^[0];
cvtEntry := args^[1];
(* XXX : UNDOCUMENTED => cvt[-1] = 0 ???? *)
if (args^[0] < 0 ) or (args^[0] >= exc.zp1.n_points) or
(args^[1] < -1) or (args^[1] >= exc.cvtSize) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
if cvtEntry < 0 then
cvt_dist := 0
else
cvt_dist := exc.func_read_cvt(cvtEntry);
(* single width test *)
if abs(cvt_dist) < exc.GS.single_width_cutin then
if cvt_dist >= 0 then cvt_dist := exc.GS.single_width_value
else cvt_dist := -exc.GS.single_width_value;
(* XXX : Undocumented - twilight zone *)
if exc.GS.gep1 = 0 then (* if in twilight zone *)
begin
exc.zp1.org^[point].x := exc.zp0.org^[exc.GS.rp0].x +
MulDiv_Round( cvt_dist,
exc.GS.freeVector.x,
$4000 );
exc.zp1.org^[point].x := exc.zp0.org^[exc.GS.rp0].y +
MulDiv_Round( cvt_dist,
exc.GS.freeVector.y,
$4000 );
exc.zp1.cur^[point] := exc.zp1.org^[point];
end;
org_dist := exc.func_dualProj( exc.zp1.org^[point],
exc.zp0.org^[exc.GS.rp0] );
cur_dist := exc.func_Project( exc.zp1.cur^[point],
exc.zp0.cur^[exc.GS.rp0] );
(* auto-flip test *)
if exc.GS.auto_flip then
if (org_dist xor cvt_dist < 0) then
cvt_dist := -cvt_dist;
(* control value cutin and round *)
if exc.opcode and 4 <> 0 then
begin
(* XXX : UNDOCUMENTED : only perform cut-in test when both *)
(* zone pointers refer to the points zone *)
if exc.GS.gep0 = exc.GS.gep1 then
if abs( cvt_dist - org_dist ) >= exc.GS.control_value_cutin then
cvt_dist := org_dist;
distance := exc.func_round( cvt_dist,
exc.metrics.compensations[ exc.opcode and 3 ] );
end
else
distance := Round_None( cvt_dist,
exc.metrics.compensations[ exc.opcode and 3 ] );
(* minimum distance test *)
if exc.opcode and 8 <> 0 then
begin
if org_dist >= 0 then
if distance < exc.GS.minimum_distance then
distance := exc.GS.minimum_distance
else
else
if distance > -exc.GS.minimum_distance then
distance := -exc.GS.minimum_distance;
end;
exc.func_move( @exc.zp1, point, distance - cur_dist );
exc.GS.rp1 := exc.GS.rp0;
if exc.opcode and 16 <> 0 then exc.GS.rp0 := point;
(* UNDOCUMENTED !! *)
exc.GS.rp2 := point;
end;
(**********************************************)
(* ALIGNRP[] : ALIGN Relative Point *)
(* CodeRange : $3C *)
procedure Ins_ALIGNRP( {%H-}args : PStorage );
var
point : Int;
distance : TT_F26dot6;
begin
if exc.top < exc.GS.loop then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
while exc.GS.loop > 0 do
begin
dec( exc.args );
point := exc.stack^[ exc.args ];
if (point < 0) or (point >= exc.zp1.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
distance := exc.func_project( exc.zp1.cur^[point],
exc.zp0.cur^[exc.GS.rp0] );
exc.func_move( @exc.zp1, point, -distance );
dec( exc.GS.loop );
end;
exc.GS.loop := 1;
exc.new_top := exc.args;
end;
(**********************************************)
(* AA[] : Adjust Angle *)
(* CodeRange : $7F *)
procedure Ins_AA( {%H-}args : PStorage );
begin
(* Intentional - no longer supported *)
end;
(**********************************************)
(* ISECT[] : moves point to InterSECTion *)
(* CodeRange : $0F *)
procedure Ins_ISECT( args : PStorage );
var
point : Int;
a0, a1 : Int;
b0, b1 : Int;
discriminant : TT_F26dot6;
dx, dy,
dax, day,
dbx, dby : TT_F26dot6;
val : TT_F26dot6;
R : TT_Vector;
begin
point := args^[0];
a0 := args^[1];
a1 := args^[2];
b0 := args^[3];
b1 := args^[4];
if (b0 >= exc.zp0.n_points) or (b1 >= exc.zp0.n_points) or
(a0 >= exc.zp1.n_points) or (a1 >= exc.zp1.n_points) or
(point >= exc.zp0.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
(*
if Normalize( exc.zp1.cur_x^[a1] - exc.zp1.cur_x^[a0],
exc.zp1.cur_y^[a1] - exc.zp1.cur_y^[a0],
U )
and
Normalize( - exc.zp0.cur_x^[b1] - exc.zp0.cur_x^[b0],
exc.zp0.cur_y^[b1] - exc.zp0.cur_y^[b0],
V )
then
begin
dx := MulDiv_Round( exc.zp0.cur_x^[b0] -
exc.zp1.cur_x^[a0],
V.x,
$4000 ) +
MulDiv_Round( exc.zp0.cur_y^[b0] -
exc.zp1.cur_y^[a0],
V.y,
$4000 );
dy := MulDiv_Round( U.x, V.x, $4000 ) +
MulDiv_Round( U.y, V.y, $4000 );
if dy <> 0 then
begin
dx := MulDiv_Round( dx, $4000, dy );
exc.zp2.flags^[point] := exc.zp2.flags^[point] or
TT_Flag_Touched_Both;
exc.zp2.cur_x^[point] := exc.zp1.cur_x^[a0] +
MulDiv_Round( dx, U.x, $4000 );
exc.zp2.cur_y^[point] := exc.zp1.cur_y^[a0] +
MulDiv_Round( dx, U.y, $4000 );
exit;
end;
end;
*)
dbx := exc.zp0.cur^[b1].x - exc.zp0.cur^[b0].x;
dby := exc.zp0.cur^[b1].y - exc.zp0.cur^[b0].y;
dax := exc.zp1.cur^[a1].x - exc.zp1.cur^[a0].x;
day := exc.zp1.cur^[a1].y - exc.zp1.cur^[a0].y;
dx := exc.zp0.cur^[b0].x - exc.zp1.cur^[a0].x;
dy := exc.zp0.cur^[b0].y - exc.zp1.cur^[a0].y;
exc.zp2.flags^[point] := exc.zp2.flags^[point] or
TT_Flag_Touched_Both;
discriminant := MulDiv( dax, -dby, $40 ) +
MulDiv( day, dbx, $40 );
if abs(discriminant) >= $40 then
begin
val := MulDiv( dx, -dby, $40 ) +
MulDiv( dy, dbx, $40 );
R.x := MulDiv( val, dax, discriminant );
R.y := MulDiv( val, day, discriminant );
exc.zp2.cur^[point].x := exc.zp1.cur^[a0].x + R.x;
exc.zp2.cur^[point].y := exc.zp1.cur^[a0].y + R.y;
end
else
begin
(* else, take the middle of the middles of A and B *)
exc.zp2.cur^[point].x := ( exc.zp1.cur^[a0].x +
exc.zp1.cur^[a1].x +
exc.zp0.cur^[b0].x +
exc.zp0.cur^[b1].x ) div 4;
exc.zp2.cur^[point].y := ( exc.zp1.cur^[a0].y +
exc.zp1.cur^[a1].y +
exc.zp0.cur^[b0].y +
exc.zp0.cur^[b1].y ) div 4;
end;
end;
(**********************************************)
(* ALIGNPTS[] : ALIGN PoinTS *)
(* CodeRange : $27 *)
procedure Ins_ALIGNPTS( args : PStorage );
var
p1, p2 : Int;
distance : TT_F26dot6;
begin
p1 := args^[0];
p2 := args^[1];
if (args^[0] < 0) or (args^[0] >= exc.zp1.n_points) or
(args^[1] < 0) or (args^[1] >= exc.zp0.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
distance := exc.func_project( exc.zp0.cur^[p2],
exc.zp1.cur^[p1] ) div 2;
exc.func_move( @exc.zp1, p1, distance );
exc.func_move( @exc.zp0, p2, -distance );
end;
(**********************************************)
(* IP[] : Interpolate Point *)
(* CodeRange : $39 *)
procedure Ins_IP( {%H-}args : PStorage );
var
org_a : TT_F26dot6;
org_b : TT_F26dot6;
org_x : TT_F26dot6;
cur_a : TT_F26dot6;
cur_b : TT_F26dot6;
cur_x : TT_F26dot6;
distance : TT_F26dot6;
point : Int;
begin
if exc.top < exc.GS.loop then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
org_a := exc.func_dualProj( exc.zp0.org^[exc.GS.rp1], Null_Vector );
org_b := exc.func_dualProj( exc.zp1.org^[exc.GS.rp2], Null_Vector );
cur_a := exc.func_project( exc.zp0.cur^[exc.GS.rp1], Null_Vector );
cur_b := exc.func_project( exc.zp1.cur^[exc.GS.rp2], Null_Vector );
while exc.GS.loop > 0 do
begin
dec( exc.args );
point := exc.stack^[ exc.args ];
org_x := exc.func_dualProj( exc.zp2.org^[point], Null_Vector );
cur_x := exc.func_project( exc.zp2.cur^[point], Null_Vector );
if (( org_a <= org_b ) and ( org_x <= org_a )) or
(( org_a > org_b ) and ( org_x >= org_a )) then
begin
distance := ( cur_a - org_a ) + ( org_x - cur_x );
end
else
if (( org_a <= org_b ) and ( org_x >= org_b )) or
(( org_a > org_b ) and ( org_x < org_b )) then
begin
distance := ( cur_b - org_b ) + ( org_x - cur_x );
end
else
begin
(* note : it seems that rounding this value isn't a good *)
(* idea ( width of capital 'S' in Times *)
distance := MulDiv( cur_b - cur_a,
org_x - org_a,
org_b - org_a ) + ( cur_a - cur_x );
end;
exc.func_move( @exc.zp2, point, distance );
dec( exc.GS.loop );
end;
exc.GS.loop := 1;
exc.new_top := exc.args;
end;
(**********************************************)
(* UTP[a] : UnTouch Point *)
(* CodeRange : $29 *)
procedure Ins_UTP( args : PStorage );
var
mask : Byte;
begin
if (args^[0] < 0) or (args^[0] >= exc.zp0.n_points) then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
mask := $FF;
if exc.GS.freeVector.x <> 0 then mask := mask and not TT_Flag_Touched_X;
if exc.GS.freeVector.y <> 0 then mask := mask and not TT_Flag_Touched_Y;
exc.zp0.flags^[args^[0]] := exc.zp0.flags^[args^[0]] and mask;
end;
(**********************************************)
(* IUP[a] : Interpolate Untouched Points *)
(* CodeRange : $30-$31 *)
procedure Ins_IUP( {%H-}args : PStorage );
var
mask : byte;
first_point, (* first point of contour *)
end_point, (* end point (last+1) of contour *)
first_touched, (* first touched point in contour *)
cur_touched, (* current touched point in contour *)
point, (* current point *)
contour : Int; (* current contour *)
orgs, (* original and current coordinate *)
curs : TT_Points; (* arrays *)
procedure Shift_X( p1, p2, p : Int );
var
i : Int;
x : TT_F26dot6;
begin
x := curs^[p].x - orgs^[p].x;
for i := p1 to p-1 do inc( curs^[i].x, x );
for i := p+1 to p2 do inc( curs^[i].x, x );
end;
procedure Shift_Y( p1, p2, p : Int );
var
i : Int;
y : TT_F26dot6;
begin
y := curs^[p].y - orgs^[p].y;
for i := p1 to p-1 do inc( curs^[i].y, y );
for i := p+1 to p2 do inc( curs^[i].y, y );
end;
procedure Interp_X( p1, p2, ref1, ref2 : Int );
var
i : Int;
x, x1, x2, d1, d2 : TT_F26dot6;
begin
if p1 > p2 then exit;
x1 := orgs^[ref1].x; d1 := curs^[ref1].x - orgs^[ref1].x;
x2 := orgs^[ref2].x; d2 := curs^[ref2].x - orgs^[ref2].x;
if x1 = x2 then
for i := p1 to p2 do
begin
x := orgs^[i].x;
if x <= x1 then x := x + d1
else x := x + d2;
curs^[i].x := x;
end
else
if x1 < x2 then
for i := p1 to p2 do
begin
x := orgs^[i].x;
if (x <= x1) then x := x + d1
else
if (x >= x2) then x := x + d2
else
x := curs^[ref1].x +
MulDiv( x-x1, curs^[ref2].x-curs^[ref1].x, x2-x1 );
curs^[i].x := x;
end
else
(* x2 < x1 *)
for i := p1 to p2 do
begin
x := orgs^[i].x;
if ( x <= x2 ) then x := x + d2
else
if ( x >= x1 ) then x := x + d1
else
x := curs^[ref1].x +
MulDiv( x-x1, curs^[ref2].x-curs^[ref1].x, x2-x1 );
curs^[i].x := x;
end;
end;
procedure Interp_Y( p1, p2, ref1, ref2 : Int );
var
i : Int;
y, y1, y2, d1, d2 : TT_F26dot6;
begin
if p1 > p2 then exit;
y1 := orgs^[ref1].y; d1 := curs^[ref1].y - orgs^[ref1].y;
y2 := orgs^[ref2].y; d2 := curs^[ref2].y - orgs^[ref2].y;
if y1 = y2 then
for i := p1 to p2 do
begin
y := orgs^[i].y;
if y <= y1 then y := y + d1
else y := y + d2;
curs^[i].y := y;
end
else
if y1 < y2 then
for i := p1 to p2 do
begin
y := orgs^[i].y;
if (y <= y1) then y := y + d1
else
if (y >= y2) then y := y + d2
else
y := curs^[ref1].y +
MulDiv( y-y1, curs^[ref2].y-curs^[ref1].y, y2-y1 );
curs^[i].y := y;
end
else
(* y2 < y1 *)
for i := p1 to p2 do
begin
y := orgs^[i].y;
if ( y <= y2 ) then y := y + d2
else
if ( y >= y1 ) then y := y + d1
else
y := curs^[ref1].y +
MulDiv( y-y1, curs^[ref2].y-curs^[ref1].y, y2-y1 );
curs^[i].y := y;
end;
end;
begin
orgs := exc.pts.org;
curs := exc.pts.cur;
case exc.opcode and 1 of
0 : mask := TT_Flag_Touched_Y;
1 : mask := TT_Flag_Touched_X;
end;
with exc do
begin
contour := 0;
point := 0;
repeat
end_point := pts.conEnds^[contour];
first_point := point;
while ( point <= end_point ) and
( pts.flags^[point] and mask = 0 ) do inc(point);
if point <= end_point then
begin
first_touched := point;
cur_touched := point;
inc( point );
while ( point <= end_point ) do
begin
if pts.flags^[point] and mask <> 0 then
begin
if opcode and 1 <> 0 then
Interp_X( cur_touched+1, point-1, cur_touched, point )
else
Interp_Y( cur_touched+1, point-1, cur_touched, point );
cur_touched := point;
end;
inc( point );
end;
if cur_touched = first_touched then
if opcode and 1 <> 0 then
Shift_X( first_point, end_point, cur_touched )
else
Shift_Y( first_point, end_point, cur_touched )
else
begin
if opcode and 1 <> 0 then
begin
interp_x( cur_touched+1, end_point, cur_touched, first_touched );
interp_x( first_point, first_touched-1, cur_touched, first_touched );
end
else
begin
interp_y( cur_touched+1, end_point, cur_touched, first_touched );
interp_y( first_point, first_touched-1, cur_touched, first_touched );
end;
end;
end;
inc( contour );
until contour >= pts.n_contours;
end;
end;
(**********************************************)
(* DELTAPn[] : DELTA Exceptions P1, P2, P3 *)
(* CodeRange : $5D,$71,$72 *)
procedure Ins_DELTAP( args : PStorage );
var
nump : Int;
k : Int;
A, B, C :Int;
begin
nump := args^[0];
for K := 1 to nump do
begin
if exc.args < 2 then
begin
exc.error := TT_Err_Too_Few_Arguments;
exit;
end;
dec( exc.args, 2 );
A := exc.stack^[exc.args+1];
B := exc.stack^[ exc.args ];
(* XXX : *)
(* some commonly fonts have broke programs where the *)
(* the point reference has an invalid value. Here, we *)
(* simply ignore them, because a DeltaP won't change *)
(* a glyph shape dramatically.. *)
(* *)
if A < exc.zp0.n_points then
begin
C := ( B and $F0 ) shr 4;
Case exc.opcode of
$5D : ;
$71 : C := C+16;
$72 : C := C+32;
end;
C := C + exc.GS.delta_Base;
if GET_Ppem = C then
begin
B := (B and $F) - 8;
if B >= 0 then B := B+1;
B := ( B*64 ) div ( 1 shl exc.GS.delta_Shift );
exc.func_move( @exc.zp0, A, B );
end;
end;
end;
exc.new_top := exc.args;
end;
(**********************************************)
(* DELTACn[] : DELTA Exceptions C1, C2, C3 *)
(* CodeRange : $73,$74,$75 *)
procedure Ins_DELTAC( args : PStorage );
var
nump : Int;
k : Int;
A, B, C :Int;
begin
nump := args^[0];
for K := 1 to nump do
begin
if exc.args < 2 then
begin
exc.error := TT_Err_Too_Few_Arguments;
exit;
end;
dec( exc.args, 2 );
A := exc.stack^[exc.args+1];
B := exc.stack^[ exc.args ];
if A >= exc.cvtSize then
begin
exc.error := TT_Err_Invalid_Reference;
exit;
end;
C := ( B and $F0 ) shr 4;
Case exc.opcode of
$73 : ;
$74 : C := C+16;
$75 : C := C+32;
end;
C := C + exc.GS.delta_Base;
if GET_Ppem = C then
begin
B := (B and $F) - 8;
if B >= 0 then B := B+1;
B := ( B*64 ) div ( 1 shl exc.GS.delta_Shift );
exc.func_move_cvt( A, B );
end;
end;
exc.new_top := exc.args;
end;
(****************************************************************)
(* *)
(* MISC. INSTRUCTIONS *)
(* *)
(****************************************************************)
(***********************************************************)
(* DEBUG[] : DEBUG. Unsupported *)
(* CodeRange : $4F *)
(* NOTE : The original instruction pops a value from the stack *)
procedure Ins_DEBUG( {%H-}args : PStorage );
begin
exc.error := TT_Err_Debug_Opcode;
end;
(**********************************************)
(* GETINFO[] : GET INFOrmation *)
(* CodeRange : $88 *)
procedure Ins_GETINFO( args : PStorage );
var
K : Int;
begin
K := 0;
if args^[0] and 1 <> 0 then K := 3;
(* We return then Windows 3.1 version number *)
(* for the font scaler *)
if false then {%H-}K := K or $80;
(* Has the glyph been rotated ? *)
(* XXXX TO DO *)
if false then {%H-}K := K or $100;
(* Has the glyph been stretched ? *)
(* XXXX TO DO *)
args^[0] := K;
end;
procedure Ins_UNKNOWN( {%H-}args : PStorage );
begin
exc.error := TT_Err_Invalid_Opcode;
end;
const
Instruct_Dispatch : array[0..255] of TInstruction_Function
= (
(* SVTCA y *) Ins_SVTCA,
(* SVTCA x *) Ins_SVTCA,
(* SPvTCA y *) Ins_SPVTCA,
(* SPvTCA x *) Ins_SPVTCA,
(* SFvTCA y *) Ins_SFVTCA,
(* SFvTCA x *) Ins_SFVTCA,
(* SPvTL // *) Ins_SPVTL,
(* SPvTL + *) Ins_SPVTL,
(* SFvTL // *) Ins_SFVTL,
(* SFvTL + *) Ins_SFVTL,
(* SPvFS *) Ins_SPVFS,
(* SFvFS *) Ins_SFVFS,
(* GPV *) Ins_GPV,
(* GFV *) Ins_GFV,
(* SFvTPv *) Ins_SFVTPV,
(* ISECT *) Ins_ISECT,
(* SRP0 *) Ins_SRP0,
(* SRP1 *) Ins_SRP1,
(* SRP2 *) Ins_SRP2,
(* SZP0 *) Ins_SZP0,
(* SZP1 *) Ins_SZP1,
(* SZP2 *) Ins_SZP2,
(* SZPS *) Ins_SZPS,
(* SLOOP *) Ins_SLOOP,
(* RTG *) Ins_RTG,
(* RTHG *) Ins_RTHG,
(* SMD *) Ins_SMD,
(* ELSE *) Ins_ELSE,
(* JMPR *) Ins_JMPR,
(* SCvTCi *) Ins_SCVTCI,
(* SSwCi *) Ins_SSWCI,
(* SSW *) Ins_SSW,
(* DUP *) Ins_DUP,
(* POP *) Ins_POP,
(* CLEAR *) Ins_CLEAR,
(* SWAP *) Ins_SWAP,
(* DEPTH *) Ins_DEPTH,
(* CINDEX *) Ins_CINDEX,
(* MINDEX *) Ins_MINDEX,
(* AlignPTS *) Ins_ALIGNPTS,
(* INS_$28 *) Ins_UNKNOWN,
(* UTP *) Ins_UTP,
(* LOOPCALL *) Ins_LOOPCALL,
(* CALL *) Ins_CALL,
(* FDEF *) Ins_FDEF,
(* ENDF *) Ins_ENDF,
(* MDAP[0] *) Ins_MDAP,
(* MDAP[1] *) Ins_MDAP,
(* IUP[0] *) Ins_IUP,
(* IUP[1] *) Ins_IUP,
(* SHP[0] *) Ins_SHP,
(* SHP[1] *) Ins_SHP,
(* SHC[0] *) Ins_SHC,
(* SHC[1] *) Ins_SHC,
(* SHZ[0] *) Ins_SHZ,
(* SHZ[1] *) Ins_SHZ,
(* SHPIX *) Ins_SHPIX,
(* IP *) Ins_IP,
(* MSIRP[0] *) Ins_MSIRP,
(* MSIRP[1] *) Ins_MSIRP,
(* AlignRP *) Ins_ALIGNRP,
(* RTDG *) Ins_RTDG,
(* MIAP[0] *) Ins_MIAP,
(* MIAP[1] *) Ins_MIAP,
(* NPushB *) Ins_NPUSHB,
(* NPushW *) Ins_NPUSHW,
(* WS *) Ins_WS,
(* RS *) Ins_RS,
(* WCvtP *) Ins_WCVTP,
(* RCvt *) Ins_RCVT,
(* GC[0] *) Ins_GC,
(* GC[1] *) Ins_GC,
(* SCFS *) Ins_SCFS,
(* MD[0] *) Ins_MD,
(* MD[1] *) Ins_MD,
(* MPPEM *) Ins_MPPEM,
(* MPS *) Ins_MPS,
(* FlipON *) Ins_FLIPON,
(* FlipOFF *) Ins_FLIPOFF,
(* DEBUG *) Ins_DEBUG,
(* LT *) Ins_LT,
(* LTEQ *) Ins_LTEQ,
(* GT *) Ins_GT,
(* GTEQ *) Ins_GTEQ,
(* EQ *) Ins_EQ,
(* NEQ *) Ins_NEQ,
(* ODD *) Ins_ODD,
(* EVEN *) Ins_EVEN,
(* IF *) Ins_IF,
(* EIF *) Ins_EIF,
(* AND *) Ins_AND,
(* OR *) Ins_OR,
(* NOT *) Ins_NOT,
(* DeltaP1 *) Ins_DELTAP,
(* SDB *) Ins_SDB,
(* SDS *) Ins_SDS,
(* ADD *) Ins_ADD,
(* SUB *) Ins_SUB,
(* DIV *) Ins_DIV,
(* MUL *) Ins_MUL,
(* ABS *) Ins_ABS,
(* NEG *) Ins_NEG,
(* FLOOR *) Ins_FLOOR,
(* CEILING *) Ins_CEILING,
(* ROUND[0] *) Ins_ROUND,
(* ROUND[1] *) Ins_ROUND,
(* ROUND[2] *) Ins_ROUND,
(* ROUND[3] *) Ins_ROUND,
(* NROUND[0]*) Ins_ROUND,
(* NROUND[1]*) Ins_ROUND,
(* NROUND[2]*) Ins_ROUND,
(* NROUND[3]*) Ins_ROUND,
(* WCvtF *) Ins_WCVTF,
(* DeltaP2 *) Ins_DELTAP,
(* DeltaP3 *) Ins_DELTAP,
(* DeltaCn[0]*) Ins_DELTAC,
(* DeltaCn[1]*) Ins_DELTAC,
(* DeltaCn[2]*) Ins_DELTAC,
(* SROUND *) Ins_SROUND,
(* S45Round *) Ins_S45ROUND,
(* JROT *) Ins_JROT,
(* JROF *) Ins_JROF,
(* ROFF *) Ins_ROFF,
(* INS_$7B *) Ins_UNKNOWN,
(* RUTG *) Ins_RUTG,
(* RDTG *) Ins_RDTG,
(* SANGW *) Ins_SANGW,
(* AA *) Ins_AA,
(* FlipPT *) Ins_FLIPPT,
(* FlipRgON *) Ins_FLIPRGON,
(* FlipRgOFF*) Ins_FLIPRGOFF,
(* INS_$83 *) Ins_UNKNOWN,
(* INS_$84 *) Ins_UNKNOWN,
(* ScanCTRL *) Ins_SCANCTRL,
(* SDPVTL[0]*) Ins_SDPVTL,
(* SDPVTL[1]*) Ins_SDPVTL,
(* GetINFO *) Ins_GETINFO,
(* IDEF *) Ins_IDEF,
(* ROLL *) Ins_ROLL,
(* MAX *) Ins_MAX,
(* MIN *) Ins_MIN,
(* ScanTYPE *) Ins_SCANTYPE,
(* InstCTRL *) Ins_INSTCTRL,
(* INS_$8F *) Ins_UNKNOWN,
(* INS_$90 *) Ins_UNKNOWN,
(* INS_$91 *) Ins_UNKNOWN,
(* INS_$92 *) Ins_UNKNOWN,
(* INS_$93 *) Ins_UNKNOWN,
(* INS_$94 *) Ins_UNKNOWN,
(* INS_$95 *) Ins_UNKNOWN,
(* INS_$96 *) Ins_UNKNOWN,
(* INS_$97 *) Ins_UNKNOWN,
(* INS_$98 *) Ins_UNKNOWN,
(* INS_$99 *) Ins_UNKNOWN,
(* INS_$9A *) Ins_UNKNOWN,
(* INS_$9B *) Ins_UNKNOWN,
(* INS_$9C *) Ins_UNKNOWN,
(* INS_$9D *) Ins_UNKNOWN,
(* INS_$9E *) Ins_UNKNOWN,
(* INS_$9F *) Ins_UNKNOWN,
(* INS_$A0 *) Ins_UNKNOWN,
(* INS_$A1 *) Ins_UNKNOWN,
(* INS_$A2 *) Ins_UNKNOWN,
(* INS_$A3 *) Ins_UNKNOWN,
(* INS_$A4 *) Ins_UNKNOWN,
(* INS_$A5 *) Ins_UNKNOWN,
(* INS_$A6 *) Ins_UNKNOWN,
(* INS_$A7 *) Ins_UNKNOWN,
(* INS_$A8 *) Ins_UNKNOWN,
(* INS_$A9 *) Ins_UNKNOWN,
(* INS_$AA *) Ins_UNKNOWN,
(* INS_$AB *) Ins_UNKNOWN,
(* INS_$AC *) Ins_UNKNOWN,
(* INS_$AD *) Ins_UNKNOWN,
(* INS_$AE *) Ins_UNKNOWN,
(* INS_$AF *) Ins_UNKNOWN,
(* PushB[0] *) Ins_PUSHB,
(* PushB[1] *) Ins_PUSHB,
(* PushB[2] *) Ins_PUSHB,
(* PushB[3] *) Ins_PUSHB,
(* PushB[4] *) Ins_PUSHB,
(* PushB[5] *) Ins_PUSHB,
(* PushB[6] *) Ins_PUSHB,
(* PushB[7] *) Ins_PUSHB,
(* PushW[0] *) Ins_PUSHW,
(* PushW[1] *) Ins_PUSHW,
(* PushW[2] *) Ins_PUSHW,
(* PushW[3] *) Ins_PUSHW,
(* PushW[4] *) Ins_PUSHW,
(* PushW[5] *) Ins_PUSHW,
(* PushW[6] *) Ins_PUSHW,
(* PushW[7] *) Ins_PUSHW,
(* MDRP[00] *) Ins_MDRP,
(* MDRP[01] *) Ins_MDRP,
(* MDRP[02] *) Ins_MDRP,
(* MDRP[03] *) Ins_MDRP,
(* MDRP[04] *) Ins_MDRP,
(* MDRP[05] *) Ins_MDRP,
(* MDRP[06] *) Ins_MDRP,
(* MDRP[07] *) Ins_MDRP,
(* MDRP[08] *) Ins_MDRP,
(* MDRP[09] *) Ins_MDRP,
(* MDRP[10] *) Ins_MDRP,
(* MDRP[11] *) Ins_MDRP,
(* MDRP[12] *) Ins_MDRP,
(* MDRP[13] *) Ins_MDRP,
(* MDRP[14] *) Ins_MDRP,
(* MDRP[15] *) Ins_MDRP,
(* MDRP[16] *) Ins_MDRP,
(* MDRP[17] *) Ins_MDRP,
(* MDRP[18] *) Ins_MDRP,
(* MDRP[19] *) Ins_MDRP,
(* MDRP[20] *) Ins_MDRP,
(* MDRP[21] *) Ins_MDRP,
(* MDRP[22] *) Ins_MDRP,
(* MDRP[23] *) Ins_MDRP,
(* MDRP[24] *) Ins_MDRP,
(* MDRP[25] *) Ins_MDRP,
(* MDRP[26] *) Ins_MDRP,
(* MDRP[27] *) Ins_MDRP,
(* MDRP[28] *) Ins_MDRP,
(* MDRP[29] *) Ins_MDRP,
(* MDRP[30] *) Ins_MDRP,
(* MDRP[31] *) Ins_MDRP,
(* MIRP[00] *) Ins_MIRP,
(* MIRP[01] *) Ins_MIRP,
(* MIRP[02] *) Ins_MIRP,
(* MIRP[03] *) Ins_MIRP,
(* MIRP[04] *) Ins_MIRP,
(* MIRP[05] *) Ins_MIRP,
(* MIRP[06] *) Ins_MIRP,
(* MIRP[07] *) Ins_MIRP,
(* MIRP[08] *) Ins_MIRP,
(* MIRP[09] *) Ins_MIRP,
(* MIRP[10] *) Ins_MIRP,
(* MIRP[11] *) Ins_MIRP,
(* MIRP[12] *) Ins_MIRP,
(* MIRP[13] *) Ins_MIRP,
(* MIRP[14] *) Ins_MIRP,
(* MIRP[15] *) Ins_MIRP,
(* MIRP[16] *) Ins_MIRP,
(* MIRP[17] *) Ins_MIRP,
(* MIRP[18] *) Ins_MIRP,
(* MIRP[19] *) Ins_MIRP,
(* MIRP[20] *) Ins_MIRP,
(* MIRP[21] *) Ins_MIRP,
(* MIRP[22] *) Ins_MIRP,
(* MIRP[23] *) Ins_MIRP,
(* MIRP[24] *) Ins_MIRP,
(* MIRP[25] *) Ins_MIRP,
(* MIRP[26] *) Ins_MIRP,
(* MIRP[27] *) Ins_MIRP,
(* MIRP[28] *) Ins_MIRP,
(* MIRP[29] *) Ins_MIRP,
(* MIRP[30] *) Ins_MIRP,
(* MIRP[31] *) Ins_MIRP
);
(****************************************************************)
(* *)
(* RUN *)
(* *)
(* This function executes a run of opcodes. It will exit *)
(* in the following cases : *)
(* *)
(* - Errors ( in which case it returns FALSE ) *)
(* *)
(* - Reaching the end of the main code range (returns TRUE) *)
(* reaching the end of a code range within a function *)
(* call is an error. *)
(* *)
(* - After executing one single opcode, if the flag *)
(* 'Instruction_Trap' is set to TRUE. (returns TRUE) *)
(* *)
(* On exit whith TRUE, test IP < CodeSize to know wether it *)
(* comes from a instruction trap or a normal termination *)
(* *)
(* *)
(* Note : The documented DEBUG opcode pops a value from *)
(* the stack. This behaviour is unsupported, here *)
(* a DEBUG opcode is always an error. *)
(* *)
(* *)
(* THIS IS THE INTERPRETER'S MAIN LOOP *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
function Run_Ins( exec : PExec_Context ) : Boolean;
label
SuiteLabel, ErrorLabel, No_Error;
var
A : Int;
begin
exc := exec^;
(* set cvt functions *)
exc.metrics.ratio := 0;
if exc.instance^.metrics.x_ppem <> exc.instance^.metrics.y_ppem then
{$IFDEF FPC}
begin
exc.func_read_cvt := @Read_CVT_Stretched;
exc.func_write_cvt := @Write_CVT_Stretched;
exc.func_move_cvt := @Move_CVT_Stretched;
end
else
begin
exc.func_read_cvt := @Read_CVT;
exc.func_write_cvt := @Write_CVT;
exc.func_move_cvt := @Move_CVT;
end;
{$ELSE}
begin
exc.func_read_cvt := Read_CVT_Stretched;
exc.func_write_cvt := Write_CVT_Stretched;
exc.func_move_cvt := Move_CVT_Stretched;
end
else
begin
exc.func_read_cvt := Read_CVT;
exc.func_write_cvt := Write_CVT;
exc.func_move_cvt := Move_CVT;
end;
{$ENDIF}
Compute_Funcs;
Compute_Round( exc.GS.round_state );
repeat
Calc_Length;
(* First, let's check for empty stack and overflow *)
exc.args := exc.top - Pop_Push_Count[ exc.opcode*2 ];
(* args is the top of the stack once arguments have been popped *)
(* one can also see it as the index of the last argument *)
if exc.args < 0 then
begin
exc.error := TT_Err_Too_Few_Arguments;
goto ErrorLabel;
end;
exc.new_top := exc.args + Pop_Push_Count[ exc.opcode*2+1 ];
(* new_top is the new top of the stack, after the instruction's *)
(* execution. top will be set to new_top after the 'case' *)
if exc.new_top > exc.stackSize then
begin
exc.error := TT_Err_Stack_Overflow;
goto ErrorLabel;
end;
exc.step_ins := true;
exc.error := TT_Err_Ok;
Instruct_Dispatch[ exc.opcode ]( PStorage(@exc.stack^[exc.args]) );
if exc.error <> TT_Err_Ok then
begin
case exc.error of
TT_Err_Invalid_Opcode: (* looking for redefined instructions *)
begin
A := 0;
while ( A < exc.numIDefs ) do
with exc.IDefs^[A] do
if Active and ( exc.opcode = Opc ) then
begin
if exc.callTop >= exc.callSize then
begin
exc.error := TT_Err_Invalid_Reference;
goto ErrorLabel;
end;
with exc.callstack^[exc.callTop] do
begin
Caller_Range := exc.curRange;
Caller_IP := exc.IP+1;
Cur_Count := 1;
Cur_Restart := Start;
end;
if not Goto_CodeRange( Range, Start ) then
goto ErrorLabel;
goto SuiteLabel;
end
else
inc(A);
exc.error := TT_Err_Invalid_Opcode;
goto ErrorLabel;
end;
else
exc.error := exc.error;
goto ErrorLabel;
end;
end;
exc.top := exc.new_top;
if exc.step_ins then inc( exc.IP, exc.length );
SuiteLabel:
if (exc.IP >= exc.codeSize) then
if exc.callTop > 0 then
begin
exc.error := TT_Err_Code_Overflow;
goto ErrorLabel;
end
else
goto No_Error;
until exc.instruction_trap;
No_Error:
Run_Ins := Success;
exec^ := exc;
exit;
ErrorLabel:
Run_Ins := Failure;
exec^ := exc;
end;
end.
Reference in New Issue View Git Blame Copy Permalink