paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-02 02:23:44 +02:00
Code Issues Packages Projects Releases Wiki Activity
a7a95f8f65
lazarus/components/lazutils/ttinterp.pas
mattias 895444b524 lazutils: less hints 
git-svn-id: trunk@55679 -
2017-08-19 08:18:44 +00:00

4972 lines
141 KiB
ObjectPascal
Raw Blame History

(*******************************************************************
*
* TTInterp.pas 2.1
*
* 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.1 and 2.0 :
*
* - Moved into TInterpreter class
* - Multithreading should be possible
* - Error log
* - Dynamic stack size
*
* Changes between 2.0 and 1.2 :
*
* - Lots, lots, of changes : This version is not re-entrant,
* but much faster.
*
*
******************************************************************)
unit TTInterp;
interface
{$R-} // TODO: Fix out-of-bounds accesses.
{$mode Delphi}
uses TTTypes,
TTObjs;
function Run_Ins( exec : PExec_Context ; AErrorLog: boolean = false) : TError;
(* Run the interpreter with the current code range and IP *)
implementation
uses
TTCalc, SysUtils, Classes, TTMemory;
const
maxStackSizeAllowed = 16000;
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 ) of object;
const
Null_Vector : TT_Vector = (x:0;y:0);
type
{ TInterpreter }
TInterpreter = class
private
pEC : PExec_Context;
opcode : Byte; (* current opcode *)
oplength : Int; (* length of current opcode *)
opargs : Int; (* number of arguments in opcode *)
top : Int; (* top of instance stack *)
new_top : Int; (* new stack top after opc. exec *)
callTop : Int; (* top of call stack *)
enableLog: boolean;
instructionLog: TStringList;
Instruct_Dispatch : array[0..255] of record
name: string;
func: TInstruction_Function;
end;
function GetLastInstruction: string;
public
constructor Create(AContext: PExec_Context; AEnableLog: boolean);
destructor Destroy; override;
function Run: TError;
property Context: PExec_Context read pEC;
property LastInstruction: string read GetLastInstruction;
private
function NeedStackSize(AValue: integer): TError; overload;
function NeedStackSize(AValue: integer; var APointerInStack : PStorage): TError; overload;
function Calc_Length: boolean;
procedure Compute_Funcs;
function Compute_Point_Displacement(out x: TT_F26dot6; out y: TT_F26dot6;
out zone: PGlyph_Zone; out refp: Int): TError;
procedure Compute_Round(round_mode: Byte);
procedure Direct_Move(zone: PGlyph_Zone; point: Int; distance: TT_F26dot6);
procedure Direct_Move_X(zone: PGlyph_Zone; point: Int; distance: TT_F26dot6
);
procedure Direct_Move_Y(zone: PGlyph_Zone; point: Int; distance: TT_F26dot6
);
function Dual_Project(var P1, P2: TT_Vector): TT_F26dot6;
function Free_Project(var P1, P2: TT_Vector): TT_F26dot6;
function GetShort: Short;
function Get_Current_Ratio: Long;
function Get_Ppem: Long;
function Goto_CodeRange(aRange, aIP: Int): boolean;
procedure Ins_AA({%H-}args: PStorage);
procedure Ins_ABS(args: PStorage);
procedure Ins_ADD(args: PStorage);
procedure Ins_ALIGNPTS(args: PStorage);
procedure Ins_ALIGNRP({%H-}args: PStorage);
procedure Ins_AND(args: PStorage);
procedure Ins_CALL(args: PStorage);
procedure Ins_CEILING(args: PStorage);
procedure Ins_CINDEX(args: PStorage);
procedure Ins_CLEAR({%H-}args: PStorage);
procedure Ins_DEBUG({%H-}args: PStorage);
procedure Ins_DELTAC(args: PStorage);
procedure Ins_DELTAP(args: PStorage);
procedure Ins_DEPTH(args: PStorage);
procedure Ins_DIV(args: PStorage);
procedure Ins_DUP(args: PStorage);
procedure Ins_EIF({%H-}args: PStorage);
procedure Ins_ELSE({%H-}args: PStorage);
procedure Ins_ENDF({%H-}args: PStorage);
procedure Ins_EQ(args: PStorage);
procedure Ins_EVEN(args: PStorage);
procedure Ins_FDEF(args: PStorage);
procedure Ins_FLIPOFF({%H-}args: PStorage);
procedure Ins_FLIPON({%H-}args: PStorage);
procedure Ins_FLIPPT({%H-}args: PStorage);
procedure Ins_FLIPRGOFF(args: PStorage);
procedure Ins_FLIPRGON(args: PStorage);
procedure Ins_FLOOR(args: PStorage);
procedure Ins_GC(args: PStorage);
procedure Ins_GETINFO(args: PStorage);
procedure Ins_GFV(args: PStorage);
procedure Ins_GPV(args: PStorage);
procedure Ins_GT(args: PStorage);
procedure Ins_GTEQ(args: PStorage);
procedure Ins_IDEF(args: PStorage);
procedure Ins_IF(args: PStorage);
procedure Ins_INSTCTRL(args: PStorage);
procedure Ins_IP({%H-}args: PStorage);
procedure Ins_ISECT(args: PStorage);
procedure Ins_IUP({%H-}args: PStorage);
procedure Ins_JMPR(args: PStorage);
procedure Ins_JROF(args: PStorage);
procedure Ins_JROT(args: PStorage);
procedure Ins_LOOPCALL(args: PStorage);
procedure Ins_LT(args: PStorage);
procedure Ins_LTEQ(args: PStorage);
procedure Ins_MAX(args: PStorage);
procedure Ins_MD(args: PStorage);
procedure Ins_MDAP(args: PStorage);
procedure Ins_MDRP(args: PStorage);
procedure Ins_MIAP(args: PStorage);
procedure Ins_MIN(args: PStorage);
procedure Ins_MINDEX(args: PStorage);
procedure Ins_MIRP(args: PStorage);
procedure Ins_MPPEM(args: PStorage);
procedure Ins_MPS(args: PStorage);
procedure Ins_MSIRP(args: PStorage);
procedure Ins_MUL(args: PStorage);
procedure Ins_NEG(args: PStorage);
procedure Ins_NEQ(args: PStorage);
procedure Ins_NOT(args: PStorage);
procedure Ins_NPUSHB(args: PStorage);
procedure Ins_NPUSHW(args: PStorage);
procedure Ins_NROUND(args: PStorage);
procedure Ins_ODD(args: PStorage);
procedure Ins_OR(args: PStorage);
procedure Ins_POP({%H-}args: PStorage);
procedure Ins_PUSHB(args: PStorage);
procedure Ins_PUSHW(args: PStorage);
procedure Ins_RCVT(args: PStorage);
procedure Ins_RDTG({%H-}args: PStorage);
procedure Ins_ROFF({%H-}args: PStorage);
procedure Ins_ROLL(args: PStorage);
procedure Ins_ROUND(args: PStorage);
procedure Ins_RS(args: PStorage);
procedure Ins_RTDG({%H-}args: PStorage);
procedure Ins_RTG({%H-}args: PStorage);
procedure Ins_RTHG({%H-}args: PStorage);
procedure Ins_RUTG({%H-}args: PStorage);
procedure Ins_S45ROUND(args: PStorage);
procedure Ins_SANGW({%H-}args: PStorage);
procedure Ins_SCANCTRL(args: PStorage);
procedure Ins_SCANTYPE(args: PStorage);
procedure Ins_SCFS(args: PStorage);
procedure Ins_SCVTCI(args: PStorage);
procedure Ins_SDB(args: PStorage);
procedure Ins_SDPVTL(args: PStorage);
procedure Ins_SDS(args: PStorage);
procedure Ins_SFVFS(args: PStorage);
procedure Ins_SFVTCA({%H-}args: PStorage);
procedure Ins_SFVTL(args: PStorage);
procedure Ins_SFVTPV({%H-}args: PStorage);
procedure Ins_SHC(args: PStorage);
procedure Ins_SHP({%H-}args: PStorage);
procedure Ins_SHPIX(args: PStorage);
procedure Ins_SHZ(args: PStorage);
procedure Ins_SLOOP(args: PStorage);
procedure Ins_SMD(args: PStorage);
procedure Ins_SPVFS(args: PStorage);
procedure Ins_SPVTCA({%H-}args: PStorage);
procedure Ins_SPVTL(args: PStorage);
procedure Ins_SROUND(args: PStorage);
procedure Ins_SRP0(args: PStorage);
procedure Ins_SRP1(args: PStorage);
procedure Ins_SRP2(args: PStorage);
procedure Ins_SSW(args: PStorage);
procedure Ins_SSWCI(args: PStorage);
procedure Ins_SUB(args: PStorage);
procedure Ins_SVTCA({%H-}args: PStorage);
procedure Ins_SWAP(args: PStorage);
function Ins_SxVTL(aIdx1: Int; aIdx2: Int; aOpc: Int; var Vec: TT_UnitVector
): boolean;
procedure Ins_SZP0(args: PStorage);
procedure Ins_SZP1(args: PStorage);
procedure Ins_SZP2(args: PStorage);
procedure Ins_SZPS(args: PStorage);
procedure Ins_UNKNOWN({%H-}args: PStorage);
procedure Ins_UTP(args: PStorage);
procedure Ins_WCVTF(args: PStorage);
procedure Ins_WCVTP(args: PStorage);
procedure Ins_WS(args: PStorage);
procedure Move_CVT(index: Int; value: TT_F26Dot6);
procedure Move_CVT_Stretched(index: Int; value: TT_F26dot6);
procedure Move_Zp2_Point(point: Int; dx: TT_F26dot6; dy: TT_F26dot6);
function Norm(X, Y: TT_F26dot6): TT_F26dot6;
function Normalize(U, V: TT_F26dot6; var R: TT_UnitVector): boolean;
function Project(var P1, P2: TT_Vector): TT_F26dot6;
function Project_x(var P1, P2: TT_Vector): TT_F26dot6;
function Project_y(var P1, P2: TT_Vector): TT_F26dot6;
function Read_CVT(index: Int): TT_F26Dot6;
function Read_CVT_Stretched(index: Int): TT_F26Dot6;
function Round_Down_To_Grid(distance: TT_F26dot6; compensation: TT_F26dot6
): TT_F26dot6;
function Round_None(distance: TT_F26dot6; compensation: TT_F26dot6
): TT_F26dot6;
function Round_Super(distance: TT_F26dot6; compensation: TT_F26dot6
): TT_F26dot6;
function Round_Super_45(distance: TT_F26dot6; compensation: TT_F26dot6
): TT_F26dot6;
function Round_To_Double_Grid(distance: TT_F26dot6; compensation: TT_F26dot6
): TT_F26dot6;
function Round_To_Grid(distance: TT_F26dot6; compensation: TT_F26dot6
): TT_F26dot6;
function Round_To_Half_Grid(distance: TT_F26dot6; compensation: TT_F26dot6
): TT_F26dot6;
function Round_Up_To_Grid(distance: TT_F26dot6; compensation: TT_F26dot6
): TT_F26dot6;
function Scale_Pixels(value: long): TT_F26Dot6;
procedure SetSuperRound(GridPeriod: TT_F26dot6; selector: Long);
function SkipCode: boolean;
procedure Write_CVT(index: Int; value: TT_F26Dot6);
procedure Write_CVT_Stretched(index: Int; value: TT_F26Dot6);
end;
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 TInterpreter.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 TInterpreter.Scale_Pixels( value : long ) : TT_F26Dot6;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Scale_Pixels := MulDiv_Round( value,
pEC^.metrics.scale1,
pEC^.metrics.scale2 );
end;
function TInterpreter.Get_Current_Ratio : Long;
var
x, y : Long;
begin
if pEC^.metrics.ratio <> 0 then
Get_Current_Ratio := pEC^.metrics.ratio
else
begin
if pEC^.GS.projVector.y = 0 then
pEC^.metrics.ratio := pEC^.metrics.x_ratio
else if pEC^.GS.projVector.x = 0 then
pEC^.metrics.ratio := pEC^.metrics.y_ratio
else
begin
x := MulDiv_Round( pEC^.GS.projVector.x,
pEC^.metrics.x_ratio,
$4000 );
y := MulDiv_Round( pEC^.GS.projVector.y,
pEC^.metrics.y_ratio,
$4000 );
pEC^.metrics.ratio := Norm( x, y );
end;
Get_Current_Ratio := pEC^.metrics.ratio;
end
end;
function TInterpreter.Get_Ppem : Long;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Get_Ppem := MulDiv_Round( pEC^.metrics.ppem, Get_Current_Ratio, $10000 );
end;
function TInterpreter.Read_CVT( index : Int ) : TT_F26Dot6;
begin
Read_CVT := pEC^.cvt^[index];
end;
function TInterpreter.Read_CVT_Stretched( index : Int ) : TT_F26Dot6;
begin
Read_CVT_Stretched := MulDiv_Round( pEC^.cvt^[index],
Get_Current_Ratio,
$10000 );
end;
procedure TInterpreter.Write_CVT( index : Int; value : TT_F26Dot6 );
begin
pEC^.cvt^[index] := value;
end;
procedure TInterpreter.Write_CVT_Stretched( index : Int; value : TT_F26Dot6 );
begin
pEC^.cvt^[index] := MulDiv_Round( value,
$10000,
Get_Current_Ratio );
end;
procedure TInterpreter.Move_CVT( index : Int; value : TT_F26Dot6 );
begin
inc( pEC^.cvt^[index], value );
end;
procedure TInterpreter.Move_CVT_Stretched( index : Int; value : TT_F26dot6 );
begin
inc( pEC^.cvt^[index], MulDiv_Round( value,
$10000,
Get_Current_Ratio ));
end;
(*******************************************************************
*
* Function : Calc_Length
*
* Description : Computes the length in bytes of current opcode
*
*****************************************************************)
function TInterpreter.Calc_Length : boolean;
begin
Calc_Length := false;
opcode := pEC^.Code^[pEC^.IP];
case opcode of
$40 : if pEC^.IP+1 >= pEC^.codeSize
then exit
else
oplength := pEC^.code^[pEC^.IP+1] + 2;
$41 : if pEC^.IP+1 >= pEC^.codeSize
then exit
else
oplength := pEC^.code^[pEC^.IP+1]*2 + 2;
$B0..$B7 : oplength := opcode-$B0 + 2;
$B8..$BF : oplength := (opcode-$B8)*2 + 3;
else
oplength := 1;
end;
Calc_Length := pEC^.IP+oplength <= pEC^.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 TInterpreter.GetShort : Short;
var
L1,L0 : Byte;
begin
L1 := pEC^.code^[pEC^.IP]; inc(pEC^.IP);
L0 := pEC^.code^[pEC^.IP]; inc(pEC^.IP);
if L1 >= 128 then
result := Short(-32768) + (Short(L1 and 127) shl 8) + L0
else
result := (L1 shl 8) + L0;
end;
function TInterpreter.Goto_CodeRange( aRange,
aIP : Int ): boolean;
begin
Goto_CodeRange := False;
with pEC^ do
begin
if (aRange<1) or (aRange>3) then
begin
pEC^.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 TInterpreter.Direct_Move( zone : PGlyph_Zone;
point : Int;
distance : TT_F26dot6 );
var
v : TT_F26dot6;
begin
v := pEC^.GS.freeVector.x;
if v <> 0 then
begin
inc( zone^.cur^[point].x, MulDiv_Round( distance,
Long(v)*$10000,
pEC^.F_dot_P ));
zone^.flags^[point] := zone^.flags^[point] or TT_Flag_Touched_X;
end;
v := pEC^.GS.freeVector.y;
if v <> 0 then
begin
inc( zone^.cur^[point].y, MulDiv_Round( distance,
Long(v)*$10000,
pEC^.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 TInterpreter.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 TInterpreter.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 TInterpreter.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 TInterpreter.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 TInterpreter.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 TInterpreter.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 TInterpreter.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 TInterpreter.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 TInterpreter.Round_Super( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
with pEC^ 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 TInterpreter.Round_Super_45( distance : TT_F26dot6;
compensation : TT_F26dot6 ) : TT_F26dot6;
var
val : TT_F26dot6;
begin
with pEC^ 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 TInterpreter.Compute_Round( round_mode : Byte );
begin
case Round_Mode of
TT_Round_Off : pEC^.func_round := Round_None;
TT_Round_To_Grid : pEC^.func_round := Round_To_Grid;
TT_Round_Up_To_Grid : pEC^.func_round := Round_Up_To_Grid;
TT_Round_Down_To_Grid : pEC^.func_round := Round_Down_To_Grid;
TT_Round_To_Half_Grid : pEC^.func_round := Round_To_Half_Grid;
TT_Round_To_Double_Grid : pEC^.func_round := Round_To_Double_Grid;
TT_Round_Super : pEC^.func_round := Round_Super;
TT_Round_Super_45 : pEC^.func_round := Round_Super_45;
end;
end;
(*******************************************************************
*
* Function : SetSuperRound
*
* Description : Set Super Round parameters
*
* Input : GridPeriod Grid period
* OpCode SROUND opcode
*
* Output : None
*
* Notes :
*
*****************************************************************)
procedure TInterpreter.SetSuperRound( GridPeriod : TT_F26dot6; selector : Long );
begin
with pEC^ 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 TInterpreter.Project( var P1, P2 : TT_Vector ) : TT_F26dot6;
var
T1, T2 : Int64;
begin
with pEC^.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 TInterpreter.Dual_Project( var P1, P2 : TT_Vector ) : TT_F26dot6;
var
T1, T2 : Int64;
begin
with pEC^.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 TInterpreter.Free_Project( var P1, P2 : TT_Vector ) : TT_F26dot6;
var
T1, T2 : Int64;
begin
with pEC^.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 TInterpreter.Project_x( var P1, P2 : TT_Vector ) : TT_F26dot6;
begin
Project_x := P1.x - P2.x;
end;
function TInterpreter.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 TInterpreter.Compute_Funcs;
begin
with pEC^, GS do
begin
if (freeVector.x = $4000) then
begin
func_freeProj := Project_x;
F_dot_P := Long(projVector.x) * $10000;
end
else
if (freeVector.y = $4000) then
begin
func_freeProj := Project_y;
F_dot_P := Long(projVector.y) * $10000;
end
else
begin
func_move := Direct_Move;
func_freeProj := Free_Project;
F_dot_P := Long(projVector.x) * freeVector.x * 4 +
Long(projVector.y) * freeVector.y * 4;
end;
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;
(* 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 TInterpreter.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;
pEC^.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 TInterpreter.Ins_DUP( args : PStorage );
begin
args^[1] := args^[0];
end;
(*******************************************)
(* POP[] : POPs the stack's top elt. *)
(* CodeRange : $21 *)
procedure TInterpreter.Ins_POP( args : PStorage );
begin
(* nothing to do *)
end;
(*******************************************)
(* CLEAR[] : Clear the entire stack *)
(* CodeRange : $22 *)
procedure TInterpreter.Ins_CLEAR( args : PStorage );
begin
new_top := 0;
end;
(*******************************************)
(* SWAP[] : Swap the top two elements *)
(* CodeRange : $23 *)
procedure TInterpreter.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 TInterpreter.Ins_DEPTH( args : PStorage );
begin
args^[0] := top;
end;
(*******************************************)
(* CINDEX[] : copy indexed element *)
(* CodeRange : $25 *)
procedure TInterpreter.Ins_CINDEX( args : PStorage );
var
L : Long;
begin
L := args^[0];
if (L <= 0) or (L > opargs) then
pEC^.error := TT_Err_Invalid_Reference
else
args^[0] := pEC^.stack^[opargs-l];
end;
(*******************************************)
(* MINDEX[] : move indexed element *)
(* CodeRange : $26 *)
procedure TInterpreter.Ins_MINDEX( args : PStorage );
var
L, K : Long;
begin
L := args^[0];
if (L <= 0) or (L > opargs) then
pEC^.Error := TT_Err_Invalid_Reference
else
begin
K := pEC^.stack^[opargs-L];
move( pEC^.stack^[opargs-L+1],
pEC^.stack^[opargs-L],
(L-1)*sizeof(Long) );
pEC^.stack^[opargs-1] := K;
end;
end;
(*******************************************)
(* ROLL[] : roll top three elements *)
(* CodeRange : $8A *)
procedure TInterpreter.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 TInterpreter.SkipCode : boolean;
var
b : Boolean;
begin
b := False;
inc( pEC^.IP, oplength );
b := pEC^.IP < pEC^.codeSize;
if b then b := Calc_Length;
if not b then
pEC^.error := TT_Err_Code_Overflow;
SkipCode := b;
end;
(*******************************************)
(* IF[] : IF test *)
(* CodeRange : $58 *)
procedure TInterpreter.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 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 TInterpreter.Ins_ELSE( args : PStorage );
var
nIfs : Int;
begin
nIfs := 1;
Repeat
if not SkipCode then exit;
case opcode of
(* IF *)
$58 : inc( nIfs );
(* EIF *)
$59 : dec( nIfs );
end;
until nIfs=0;
end;
(*******************************************)
(* EIF[] : End IF *)
(* CodeRange : $59 *)
procedure TInterpreter.Ins_EIF( args : PStorage );
begin
(* nothing to do *)
end;
(*******************************************)
(* JROT[] : Jump Relative On True *)
(* CodeRange : $78 *)
procedure TInterpreter.Ins_JROT( args : PStorage );
begin
if args^[1] <> 0 then
begin
inc( pEC^.IP, args^[0] );
pEC^.step_ins := false;
end;
end;
(*******************************************)
(* JMPR[] : JuMP Relative *)
(* CodeRange : $1C *)
procedure TInterpreter.Ins_JMPR( args : PStorage );
begin
inc( pEC^.IP, args^[0] );
pEC^.step_ins := false;
end;
(*******************************************)
(* JROF[] : Jump Relative On False *)
(* CodeRange : $79 *)
procedure TInterpreter.Ins_JROF( args : PStorage );
begin
if args^[1] = 0 then
begin
inc( pEC^.IP, args^[0] );
pEC^.step_ins := false;
end;
end;
(****************************************************************)
(* *)
(* LOGICAL FUNCTIONS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* LT[] : Less Than *)
(* CodeRange : $50 *)
procedure TInterpreter.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 TInterpreter.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 TInterpreter.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 TInterpreter.Ins_GTEQ( args : PStorage );
begin
if args^[0] >= args^[1] then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* EQ[] : EQual *)
(* CodeRange : $54 *)
procedure TInterpreter.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 TInterpreter.Ins_NEQ( args : PStorage );
begin
if args^[0] <> args^[1] then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* ODD[] : Odd *)
(* CodeRange : $56 *)
procedure TInterpreter.Ins_ODD( args : PStorage );
begin
if pEC^.func_round( args^[0], 0 ) and 127 = 64 then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* EVEN[] : Even *)
(* CodeRange : $57 *)
procedure TInterpreter.Ins_EVEN( args : PStorage );
begin
if pEC^.func_round( args^[0], 0 ) and 127 = 0 then args^[0] := 1
else args^[0] := 0;
end;
(*******************************************)
(* AND[] : logical AND *)
(* CodeRange : $5A *)
procedure TInterpreter.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 TInterpreter.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 TInterpreter.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 TInterpreter.Ins_ADD( args : PStorage );
begin
inc( args^[0], args^[1] );
end;
(*******************************************)
(* SUB[] : SUBstract *)
(* CodeRange : $61 *)
procedure TInterpreter.Ins_SUB( args : PStorage );
begin
dec( args^[0], args^[1] );
end;
(*******************************************)
(* DIV[] : DIVide *)
(* CodeRange : $62 *)
procedure TInterpreter.Ins_DIV( args : PStorage );
begin
if args^[1] = 0 then
begin
pEC^.error := TT_Err_Divide_By_Zero;
exit;
end;
args^[0] := MulDiv_Round( args^[0], 64, args^[1] );
end;
(*******************************************)
(* MUL[] : MULtiply *)
(* CodeRange : $63 *)
procedure TInterpreter.Ins_MUL( args : PStorage );
begin
args^[0] := MulDiv_Round( args^[0], args^[1], 64 );
end;
(*******************************************)
(* ABS[] : ABSolute value *)
(* CodeRange : $64 *)
procedure TInterpreter.Ins_ABS( args : PStorage );
begin
args^[0] := abs( args^[0] );
end;
(*******************************************)
(* NEG[] : NEGate *)
(* CodeRange : $65 *)
procedure TInterpreter.Ins_NEG( args : PStorage );
begin
args^[0] := -args^[0];
end;
(*******************************************)
(* FLOOR[] : FLOOR *)
(* CodeRange : $66 *)
procedure TInterpreter.Ins_FLOOR( args : PStorage );
begin
args^[0] := args^[0] and -64;
end;
(*******************************************)
(* CEILING[] : CEILING *)
(* CodeRange : $67 *)
procedure TInterpreter.Ins_CEILING( args : PStorage );
begin
args^[0] := ( args^[0]+63 ) and -64;
end;
(*******************************************)
(* MAX[] : MAXimum *)
(* CodeRange : $68 *)
procedure TInterpreter.Ins_MAX( args : PStorage );
begin
if args^[1] > args^[0] then args^[0] := args^[1];
end;
(*******************************************)
(* MIN[] : MINimum *)
(* CodeRange : $69 *)
procedure TInterpreter.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 TInterpreter.Ins_ROUND( args : PStorage );
begin
args^[0] := pEC^.func_round( args^[0],
pEC^.metrics.compensations[ opcode-$68 ] );
end;
(*******************************************)
(* NROUND[ab]: No ROUNDing of value *)
(* CodeRange : $6C-$6F *)
procedure TInterpreter.Ins_NROUND( args : PStorage );
begin
args^[0] := Round_None( args^[0],
pEC^.metrics.compensations[ opcode-$6C ] );
end;
(****************************************************************)
(* *)
(* DEFINING AND USING FUNCTIONS AND INSTRUCTIONS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* FDEF[] : Function DEFinition *)
(* CodeRange : $2C *)
procedure TInterpreter.Ins_FDEF( args : PStorage );
var
func : int;
begin
(* check space *)
if pEC^.numFDefs >= pEC^.maxFDefs then begin
pEC^.error := TT_Err_Too_Many_FuncDefs;
exit;
end;
func := Int(args^[0]);
with pEC^.FDefs^[pEC^.numFDefs] do
begin
Range := pEC^.curRange;
Opc := func;
Start := pEC^.IP+1;
Active := True;
end;
if func > pEC^.maxFunc then
pEC^.maxFunc := func;
inc(pEC^.numFDefs);
(* now skip the whole function definition *)
(* we don't allow nested IDEFS & FDEFs *)
while SkipCode do
case opcode of
$89, (* IDEF *)
$2C : (* FDEF *)
begin
pEC^.error := TT_Err_Nested_Defs;
exit;
end;
$2D : (* ENDF *)
exit;
end;
end;
(*******************************************)
(* ENDF[] : END Function definition *)
(* CodeRange : $2D *)
procedure TInterpreter.Ins_ENDF( args : PStorage );
begin
if callTop <= 0 then (* We encountered an ENDF without a call *)
begin
pEC^.error := TT_Err_ENDF_in_Exec_Stream;
exit;
end;
dec( callTop );
with pEC^.Callstack^[callTop] do
begin
dec( Cur_Count );
pEC^.step_ins := false;
if Cur_Count > 0 then
begin
(* Loop the current function *)
inc( callTop );
pEC^.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 TInterpreter.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] > pEC^.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 : *)
(* *)
(* pEC^.maxFunc+1 = pEC^.numFDefs *)
(* pEC^.FDefs[n].opc = n for n in 0..pEC^.maxFunc *)
(* *)
nn := Int(args^[0]);
def := @pEC^.FDefs^[nn];
if ( pEC^.maxFunc+1 <> pEC^.numFDefs ) or ( def^.opc <> nn ) then begin
(* lookup the FDefs table *)
ii := 0;
def := @pEC^.FDefs^[0];
while (ii < pEC^.numFDefs) and (def^.opc <> nn) do begin
inc(ii);
inc(def);
end;
(* Fail if the function isn't listed *)
if ii >= pEC^.numFDefs then
goto Fail;
end;
(* check that the function is active *)
if not def^.active then
goto Fail;
(* check call stack *)
if callTop >= pEC^.callSize then
begin
pEC^.error := TT_Err_Stack_Overflow;
exit;
end;
with pEC^.callstack^[callTop] do
begin
Caller_Range := pEC^.curRange;
Caller_IP := pEC^.IP+1;
Cur_Count := 1;
Cur_Restart := def^.Start;
end;
inc( callTop );
with def^ do Goto_CodeRange( Range, Start );
pEC^.step_ins := false;
exit;
Fail:
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
(*******************************************)
(* LOOPCALL[]: LOOP and CALL function *)
(* CodeRange : $2A *)
procedure TInterpreter.Ins_LOOPCALL( args : PStorage );
begin
if ( args^[1] < 0 ) or ( args^[1] >= pEC^.numFDefs ) or
( not pEC^.FDefs^[args^[1]].Active ) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
if callTop >= pEC^.callSize then
begin
pEC^.error := TT_Err_Stack_Overflow;
exit;
end;
if args^[0] > 0 then
begin
with pEC^.callstack^[callTop] do
begin
Caller_Range := pEC^.curRange;
Caller_IP := pEC^.IP+1;
Cur_Count := args^[0];
Cur_Restart := pEC^.FDefs^[args^[1]].Start;
end;
inc( callTop );
with pEC^.FDefs^[args^[1]] do Goto_CodeRange( Range, Start );
pEC^.step_ins := false;
end;
end;
(*******************************************)
(* IDEF[] : Instruction DEFinition *)
(* CodeRange : $89 *)
procedure TInterpreter.Ins_IDEF( args : PStorage );
var
A : Int;
begin
A := 0;
while ( A < pEC^.numIDefs ) do
with pEC^.IDefs^[A] do
begin
if not Active then
begin
Opc := args^[0];
Start := pEC^.IP+1;
Range := pEC^.curRange;
Active := True;
A := pEC^.numIDefs;
(* now skip the whole function definition *)
(* we don't allow nested IDEFS & FDEFs *)
while SkipCode do
case opcode of
$89, (* IDEF *)
$2C : (* FDEF *)
begin
pEC^.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 TInterpreter.Ins_NPUSHB( args : PStorage );
var
L, K : Long;
begin
L := pEC^.code^[pEC^.IP+1];
if NeedStackSize(top + L, args) then exit;
for K := 1 to L do
args^[k-1] := pEC^.code^[pEC^.IP+1+k];
inc( new_top, L );
end;
(*******************************************)
(* NPUSHW[] : PUSH N Words *)
(* CodeRange : $41 *)
procedure TInterpreter.Ins_NPUSHW( args : PStorage );
var
L, K : Long;
begin
L := pEC^.code^[pEC^.IP+1];
if NeedStackSize(top + L, args) then exit;
inc( pEC^.IP, 2 );
for K := 1 to L do
args^[k-1] := GetShort;
pEC^.step_ins := false;
inc( new_top, L );
end;
(*******************************************)
(* PUSHB[abc]: PUSH Bytes *)
(* CodeRange : $B0-$B7 *)
procedure TInterpreter.Ins_PUSHB( args : PStorage );
var
L, K : Long;
begin
L := opcode - $B0+1;
if NeedStackSize(top + L + 1, args) then exit;
for k := 1 to L do
args^[k-1] := pEC^.code^[pEC^.ip+k];
end;
(*******************************************)
(* PUSHW[abc]: PUSH Words *)
(* CodeRange : $B8-$BF *)
procedure TInterpreter.Ins_PUSHW( args : PStorage );
var
L, K : Long;
begin
L := opcode - $B8+1;
if NeedStackSize(top + L + 1, args) then exit;
inc( pEC^.IP );
for k := 1 to L do
args^[k-1] := GetShort;
pEC^.step_ins := false;
end;
(****************************************************************)
(* *)
(* MANAGING THE STORAGE AREA *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* RS[] : Read Store *)
(* CodeRange : $43 *)
procedure TInterpreter.Ins_RS( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= pEC^.storeSize) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
args^[0] := pEC^.storage^[args^[0]];
end;
(*******************************************)
(* WS[] : Write Store *)
(* CodeRange : $42 *)
procedure TInterpreter.Ins_WS( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= pEC^.storeSize) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
pEC^.storage^[args^[0]] := args^[1];
end;
(*******************************************)
(* WCVTP[] : Write CVT in Pixel units *)
(* CodeRange : $44 *)
procedure TInterpreter.Ins_WCVTP( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= pEC^.cvtSize) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
pEC^.func_write_cvt( args^[0], args^[1] );
end;
(*******************************************)
(* WCVTF[] : Write CVT in FUnits *)
(* CodeRange : $70 *)
procedure TInterpreter.Ins_WCVTF( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= pEC^.cvtSize) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
pEC^.cvt^[args^[0]] := Scale_Pixels(args^[1]);
end;
(*******************************************)
(* RCVT[] : Read CVT *)
(* CodeRange : $45 *)
procedure TInterpreter.Ins_RCVT( args : PStorage );
begin
if (args^[0] < 0) or (args^[0] >= pEC^.cvtSize) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
args^[0] := pEC^.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 TInterpreter.Ins_SVTCA( args : PStorage );
var A, B : Short;
begin
case (opcode and 1) of
0 : A := $0000;
1 : A := $4000;
end;
B := A xor $4000;
pEC^.GS.freeVector.x := A;
pEC^.GS.projVector.x := A;
pEC^.GS.dualVector.x := A;
pEC^.GS.freeVector.y := B;
pEC^.GS.projVector.y := B;
pEC^.GS.dualVector.y := B;
Compute_Funcs;
end;
(*******************************************)
(* SPVTCA[a] : Set PVector to Axis *)
(* CodeRange : $02-$03 *)
procedure TInterpreter.Ins_SPVTCA( args : PStorage );
var A, B : Short;
begin
case (opcode and 1) of
0 : A := $0000;
1 : A := $4000;
end;
B := A xor $4000;
pEC^.GS.projVector.x := A;
pEC^.GS.dualVector.x := A;
pEC^.GS.projVector.y := B;
pEC^.GS.dualVector.y := B;
Compute_Funcs;
end;
(*******************************************)
(* SFVTCA[a] : Set FVector to Axis *)
(* CodeRange : $04-$05 *)
procedure TInterpreter.Ins_SFVTCA( args : PStorage );
var A, B : Short;
begin
case (opcode and 1) of
0 : A := $0000;
1 : A := $4000;
end;
B := A xor $4000;
pEC^.GS.freeVector.x := A;
pEC^.GS.freeVector.y := B;
Compute_Funcs;
end;
function TInterpreter.Ins_SxVTL( aIdx1 : Int;
aIdx2 : Int;
aOpc : Int;
var Vec : TT_UnitVector ) : boolean;
var
A, B, C : Long;
begin
Ins_SxVTL := False;
with pEC^ 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
pEC^.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 TInterpreter.Ins_SPVTL( args : PStorage );
begin
if not INS_SxVTL( args^[1],
args^[0],
opcode,
pEC^.GS.projVector ) then exit;
pEC^.GS.dualVector := pEC^.GS.projVector;
Compute_Funcs;
end;
(*******************************************)
(* SFVTL[a] : Set FVector to Line *)
(* CodeRange : $08-$09 *)
procedure TInterpreter.Ins_SFVTL( args : PStorage );
begin
if not INS_SxVTL( args^[1],
args^[0],
opcode,
pEC^.GS.freeVector ) then exit;
Compute_Funcs;
end;
(*******************************************)
(* SFVTPV[] : Set FVector to PVector *)
(* CodeRange : $0E *)
procedure TInterpreter.Ins_SFVTPV( args : PStorage );
begin
pEC^.GS.freeVector := pEC^.GS.projVector;
Compute_Funcs;
end;
(*******************************************)
(* SDPVTL[a] : Set Dual PVector to Line *)
(* CodeRange : $86-$87 *)
procedure TInterpreter.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] >= pEC^.zp1.n_points) or
(args^[1] < 0) or (args^[1] >= pEC^.zp2.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
A := pEC^.zp1.org^[p2].x - pEC^.zp2.org^[p1].x;
B := pEC^.zp1.org^[p2].y - pEC^.zp2.org^[p1].y;
if opcode and 1 <> 0 then
begin
C := B; (* CounterClockwise rotation *)
B := A;
A := -C;
end;
Normalize( A, B, pEC^.GS.dualVector );
A := pEC^.zp1.cur^[p2].x - pEC^.zp2.cur^[p1].x;
B := pEC^.zp1.cur^[p2].y - pEC^.zp2.cur^[p1].y;
if opcode and 1 <> 0 then
begin
C := B; (* CounterClockwise rotation *)
B := A;
A := -C;
end;
Normalize( A, B, pEC^.GS.projVector );
Compute_Funcs;
pEC^.error := TT_Err_Ok;
end;
(*******************************************)
(* SPVFS[] : Set PVector From Stack *)
(* CodeRange : $0A *)
procedure TInterpreter.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, pEC^.GS.projVector ) then exit;
pEC^.GS.dualVector := pEC^.GS.projVector;
Compute_Funcs;
end;
(*******************************************)
(* SFVFS[] : Set FVector From Stack *)
(* CodeRange : $0B *)
procedure TInterpreter.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, pEC^.GS.freeVector ) then exit;
Compute_Funcs;
end;
(*******************************************)
(* GPV[] : Get Projection Vector *)
(* CodeRange : $0C *)
procedure TInterpreter.Ins_GPV( args : PStorage );
begin
args^[0] := pEC^.GS.projVector.x;
args^[1] := pEC^.GS.projVector.y;
end;
(*******************************************)
(* GFV[] : Get Freedom Vector *)
(* CodeRange : $0D *)
procedure TInterpreter.Ins_GFV( args : PStorage );
begin
args^[0] := pEC^.GS.freeVector.x;
args^[1] := pEC^.GS.freeVector.y;
end;
(*******************************************)
(* SRP0[] : Set Reference Point 0 *)
(* CodeRange : $10 *)
procedure TInterpreter.Ins_SRP0( args : PStorage );
begin
pEC^.GS.rp0 := args^[0];
end;
(*******************************************)
(* SRP1[] : Set Reference Point 1 *)
(* CodeRange : $11 *)
procedure TInterpreter.Ins_SRP1( args : PStorage );
begin
pEC^.GS.rp1 := args^[0];
end;
(*******************************************)
(* SRP2[] : Set Reference Point 2 *)
(* CodeRange : $12 *)
procedure TInterpreter.Ins_SRP2( args : PStorage );
begin
pEC^.GS.rp2 := args^[0];
end;
(*******************************************)
(* SZP0[] : Set Zone Pointer 0 *)
(* CodeRange : $13 *)
procedure TInterpreter.Ins_SZP0( args : PStorage );
begin
case args^[0] of
0 : pEC^.zp0 := pEC^.Twilight;
1 : pEC^.zp0 := pEC^.Pts;
else
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
pEC^.GS.gep0 := args^[0];
end;
(*******************************************)
(* SZP1[] : Set Zone Pointer 1 *)
(* CodeRange : $14 *)
procedure TInterpreter.Ins_SZP1( args : PStorage );
begin
case args^[0] of
0 : pEC^.zp1 := pEC^.Twilight;
1 : pEC^.zp1 := pEC^.Pts;
else
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
pEC^.GS.gep1 := args^[0];
end;
(*******************************************)
(* SZP2[] : Set Zone Pointer 2 *)
(* CodeRange : $15 *)
procedure TInterpreter.Ins_SZP2( args : PStorage );
begin
case args^[0] of
0 : pEC^.zp2 := pEC^.Twilight;
1 : pEC^.zp2 := pEC^.Pts;
else
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
pEC^.GS.gep2 := args^[0];
end;
(*******************************************)
(* SZPS[] : Set Zone Pointers *)
(* CodeRange : $16 *)
procedure TInterpreter.Ins_SZPS( args : PStorage );
begin
case args^[0] of
0 : pEC^.zp0 := pEC^.Twilight;
1 : pEC^.zp0 := pEC^.Pts;
else
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
pEC^.zp1 := pEC^.zp0;
pEC^.zp2 := pEC^.zp0;
pEC^.GS.gep0 := args^[0];
pEC^.GS.gep1 := args^[0];
pEC^.GS.gep2 := args^[0];
end;
(*******************************************)
(* RTHG[] : Round To Half Grid *)
(* CodeRange : $19 *)
procedure TInterpreter.Ins_RTHG( args : PStorage );
begin
pEC^.GS.round_state := TT_Round_To_Half_Grid;
pEC^.func_round := Round_To_Half_Grid;
end;
(*******************************************)
(* RTG[] : Round To Grid *)
(* CodeRange : $18 *)
procedure TInterpreter.Ins_RTG( args : PStorage );
begin
pEC^.GS.round_state := TT_Round_To_Grid;
pEC^.func_round := Round_To_Grid;
end;
(*******************************************)
(* RTDG[] : Round To Double Grid *)
(* CodeRange : $3D *)
procedure TInterpreter.Ins_RTDG( args : PStorage );
begin
pEC^.GS.round_state := TT_Round_To_Double_Grid;
pEC^.func_round := Round_To_Double_Grid;
end;
(*******************************************)
(* RUTG[] : Round Up To Grid *)
(* CodeRange : $7C *)
procedure TInterpreter.Ins_RUTG( args : PStorage );
begin
pEC^.GS.round_state := TT_Round_Up_To_Grid;
pEC^.func_round := Round_Up_To_Grid;
end;
(*******************************************)
(* RDTG[] : Round Down To Grid *)
(* CodeRange : $7D *)
procedure TInterpreter.Ins_RDTG( args : PStorage );
begin
pEC^.GS.round_state := TT_Round_Down_To_Grid;
pEC^.func_round := Round_Down_To_Grid;
end;
(*******************************************)
(* ROFF[] : Round OFF *)
(* CodeRange : $7A *)
procedure TInterpreter.Ins_ROFF( args : PStorage );
begin
pEC^.GS.round_state := TT_Round_Off;
pEC^.func_round := Round_None;
end;
(*******************************************)
(* SROUND[] : Super ROUND *)
(* CodeRange : $76 *)
procedure TInterpreter.Ins_SROUND( args : PStorage );
begin
SetSuperRound( $4000, args^[0] );
pEC^.GS.round_state := TT_Round_Super;
pEC^.func_round := Round_Super;
end;
(*******************************************)
(* S45ROUND[]: Super ROUND 45 degrees *)
(* CodeRange : $77 *)
procedure TInterpreter.Ins_S45ROUND( args : PStorage );
begin
SetSuperRound( $2D41, args^[0] );
pEC^.GS.round_state := TT_Round_Super_45;
pEC^.func_round := Round_Super_45;
end;
(*******************************************)
(* SLOOP[] : Set LOOP variable *)
(* CodeRange : $17 *)
procedure TInterpreter.Ins_SLOOP( args : PStorage );
begin
pEC^.GS.Loop := args^[0];
end;
(*******************************************)
(* SMD[] : Set Minimum Distance *)
(* CodeRange : $1A *)
procedure TInterpreter.Ins_SMD( args : PStorage );
begin
pEC^.GS.minimum_distance := args^[0];
end;
(*******************************************)
(* INSTCTRL[]: INSTruction ConTRol *)
(* CodeRange : $8e *)
procedure TInterpreter.Ins_INSTCTRL( args : PStorage );
var
K, L : Int;
begin
K := args^[1];
L := args^[0];
if ( K < 1 ) or ( K > 2 ) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
if L <> 0 then L := K;
pEC^.GS.instruct_control := ( pEC^.GS.instruct_control and not K ) or L;
end;
(*******************************************)
(* SCANCTRL[]: SCAN ConTRol *)
(* CodeRange : $85 *)
procedure TInterpreter.Ins_SCANCTRL( args : PStorage );
var
A : Int;
begin
(* Get Threshold *)
A := args^[0] and $FF;
if A = $FF then
pEC^.GS.scan_Control := True
else
if A = 0 then
pEC^.GS.scan_Control := False
else
begin
A := A * 64;
(* XXX TODO : Add rotation and stretch cases *)
if ( args^[0] and $100 <> 0 ) and
( pEC^.metrics.pointSize <= A ) then pEC^.GS.scan_Control := True;
//if ( args^[0] and $200 <> 0 ) and
// ( false ) then pEC^.GS.scan_Control := True;
//if ( args^[0] and $400 <> 0 ) and
// ( false ) then pEC^.GS.scan_Control := True;
if ( args^[0] and $800 <> 0 ) and
( pEC^.metrics.pointSize > A ) then pEC^.GS.scan_Control := False;
if ( args^[0] and $1000 <> 0 ) and
( not False ) then pEC^.GS.scan_Control := False;
if ( args^[0] and $2000 <> 0 ) and
( not False ) then pEC^.GS.scan_Control := False;
end;
end;
(*******************************************)
(* SCANTYPE[]: SCAN TYPE *)
(* CodeRange : $8D *)
procedure TInterpreter.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;
pEC^.GS.scan_type := args^[0];
end;
end;
(**********************************************)
(* SCVTCI[] : Set Control Value Table Cut In *)
(* CodeRange : $1D *)
procedure TInterpreter.Ins_SCVTCI( args : PStorage );
begin
pEC^.GS.control_value_cutin := args^[0];
end;
(**********************************************)
(* SSWCI[] : Set Single Width Cut In *)
(* CodeRange : $1E *)
procedure TInterpreter.Ins_SSWCI( args : PStorage );
begin
pEC^.GS.single_width_cutin := args^[0];
end;
(**********************************************)
(* SSW[] : Set Single Width *)
(* CodeRange : $1F *)
procedure TInterpreter.Ins_SSW( args : PStorage );
begin
pEC^.GS.single_width_value := args^[0] div $400;
end;
(**********************************************)
(* FLIPON[] : Set Auto_flip to On *)
(* CodeRange : $4D *)
procedure TInterpreter.Ins_FLIPON( args : PStorage );
begin
pEC^.GS.auto_flip := True;
end;
(**********************************************)
(* FLIPOFF[] : Set Auto_flip to Off *)
(* CodeRange : $4E *)
procedure TInterpreter.Ins_FLIPOFF( args : PStorage );
begin
pEC^.GS.auto_flip := False;
end;
(**********************************************)
(* SANGW[] : Set Angle Weigth *)
(* CodeRange : $7E *)
procedure TInterpreter.Ins_SANGW( args : PStorage );
begin
(* instruction not supported anymore *)
end;
(**********************************************)
(* SDB[] : Set Delta Base *)
(* CodeRange : $5E *)
procedure TInterpreter.Ins_SDB( args : PStorage );
begin
pEC^.GS.delta_base := args^[0]
end;
(**********************************************)
(* SDS[] : Set Delta Shift *)
(* CodeRange : $5F *)
procedure TInterpreter.Ins_SDS( args : PStorage );
begin
pEC^.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 TInterpreter.Ins_GC( args : PStorage );
var
L : Int;
begin
L := args^[0];
if (L < 0) or (L >= pEC^.zp2.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
case opcode and 1 of
0 : L := pEC^.func_project ( pEC^.zp2.cur^[L], Null_Vector );
1 : L := pEC^.func_dualProj( pEC^.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 TInterpreter.Ins_SCFS( args : PStorage );
var
K, L : Int;
begin
L := args^[0];
if (args^[0] < 0) or (args^[0] >= pEC^.zp2.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
K := pEC^.func_project( pEC^.zp2.cur^[L], Null_Vector );
pEC^.func_move( @pEC^.zp2, L, args^[1] - K );
(* not part of the specs, but here for safety *)
if pEC^.GS.gep2 = 0 then
pEC^.zp2.org^[L] := pEC^.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 TInterpreter.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] >= pEC^.zp0.n_points) or
(args^[1] < 0) or (args^[1] >= pEC^.zp1.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
case opcode and 1 of
0 : D := pEC^.func_dualProj( pEC^.zp0.org^[L], pEC^.zp1.org^[K] );
1 : D := pEC^.func_project ( pEC^.zp0.cur^[L], pEC^.zp1.cur^[K] );
end;
args^[0] := D;
end;
(**********************************************)
(* MPPEM[] : Measure Pixel Per EM *)
(* CodeRange : $4B *)
procedure TInterpreter.Ins_MPPEM( args : PStorage );
begin
args^[0] := Get_Ppem;
end;
(**********************************************)
(* MPS[] : Measure PointSize *)
(* CodeRange : $4C *)
procedure TInterpreter.Ins_MPS( args : PStorage );
begin
args^[0] := pEC^.metrics.pointSize;
end;
(****************************************************************)
(* *)
(* MANAGING OUTLINES *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(**********************************************)
(* FLIPPT[] : FLIP PoinT *)
(* CodeRange : $80 *)
procedure TInterpreter.Ins_FLIPPT( args : PStorage );
var
point : Int;
begin
if top < pEC^.GS.loop then
begin
pEC^.error := TT_Err_Too_Few_Arguments;
exit;
end;
while pEC^.GS.loop > 0 do
begin
dec( opargs );
point := pEC^.stack^[ opargs ];
if (point < 0) or (point >= pEC^.pts.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
pEC^.pts.flags^[point] := pEC^.pts.flags^[point] xor TT_Flag_On_Curve;
dec( pEC^.GS.loop );
end;
pEC^.GS.loop := 1;
new_top := opargs;
end;
(**********************************************)
(* FLIPRGON[]: FLIP RanGe ON *)
(* CodeRange : $81 *)
procedure TInterpreter.Ins_FLIPRGON( args : PStorage );
var
I, K, L : Int;
begin
K := args^[1];
L := args^[0];
if (K < 0) or (K >= pEC^.pts.n_points) or
(L < 0) or (L >= pEC^.pts.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
for I := L to K do
pEC^.pts.flags^[I] := pEC^.pts.flags^[I] or TT_Flag_On_Curve;
end;
(**********************************************)
(* FLIPRGOFF : FLIP RanGe OFF *)
(* CodeRange : $82 *)
procedure TInterpreter.Ins_FLIPRGOFF( args : PStorage );
var
I, K, L : Int;
begin
K := args^[1];
L := args^[0];
if (K < 0) or (K >= pEC^.pts.n_points) or
(L < 0) or (L >= pEC^.pts.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
for I := L to K do
pEC^.pts.flags^[I] := pEC^.pts.flags^[I] and not TT_Flag_On_Curve;
end;
function TInterpreter.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 opcode and 1 of
0 : begin zp := @pEC^.zp1; p := pEC^.GS.rp2; end;
1 : begin zp := @pEC^.zp0; p := pEC^.GS.rp1; end;
end;
if (p < 0) or (p >= zp^.n_points) then
begin
pEC^.error := TT_Err_Invalid_Displacement;
Compute_Point_Displacement := Failure;
exit;
end;
zone := zp;
refp := p;
d := pEC^.func_project( zp^.cur^[p], zp^.org^[p] );
x := MulDiv_Round( d, Long(pEC^.GS.freeVector.x)*$10000, pEC^.F_dot_P );
y := MulDiv_Round( d, Long(pEC^.GS.freeVector.y)*$10000, pEC^.F_dot_P );
end;
procedure TInterpreter.Move_Zp2_Point( point : Int;
dx : TT_F26dot6;
dy : TT_F26dot6 );
begin
if pEC^.GS.freeVector.x <> 0 then
begin
inc( pEC^.zp2.cur^[point].x, dx );
pEC^.zp2.flags^[point] := pEC^.zp2.flags^[point] or TT_Flag_Touched_X;
end;
if pEC^.GS.freeVector.y <> 0 then
begin
inc( pEC^.zp2.cur^[point].y, dy );
pEC^.zp2.flags^[point] := pEC^.zp2.flags^[point] or TT_Flag_Touched_Y;
end;
end;
(**********************************************)
(* SHP[a] : SHift Point by the last point *)
(* CodeRange : $32-33 *)
procedure TInterpreter.Ins_SHP( 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 top < pEC^.GS.loop then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
while pEC^.GS.loop > 0 do
begin
dec( opargs );
point := pEC^.stack^[ opargs ];
if (point < 0) or (point >= pEC^.zp2.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
Move_Zp2_Point( point, dx, dy );
dec( pEC^.GS.loop );
end;
pEC^.GS.loop := 1;
new_top := opargs;
end;
(**********************************************)
(* SHC[a] : SHift Contour *)
(* CodeRange : $34-35 *)
procedure TInterpreter.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] >= pEC^.pts.n_contours ) then
begin
pEC^.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 := pEC^.pts.conEnds^[contour-1]+1;
last_point := pEC^.pts.conEnds^[contour];
for i := first_point to last_point do
begin
if (zp^.cur <> pEC^.zp2.cur) or
(refp <> i ) then
Move_Zp2_Point( i, dx, dy );
end;
end;
(**********************************************)
(* SHZ[a] : SHift Zone *)
(* CodeRange : $36-37 *)
procedure TInterpreter.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
pEC^.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 <> pEC^.zp2.cur) or
(refp <> i ) then
Move_Zp2_Point( i, dx, dy );
end;
end;
(**********************************************)
(* SHPIX[] : SHift points by a PIXel amount *)
(* CodeRange : $38 *)
procedure TInterpreter.Ins_SHPIX( args : PStorage );
var
dx : TT_F26dot6;
dy : TT_F26dot6;
point: Int;
begin
if top < pEC^.GS.loop then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
dx := MulDiv_Round( args^[0],
pEC^.GS.freeVector.x,
$4000 );
dy := MulDiv_Round( args^[0],
pEC^.GS.freeVector.y,
$4000 );
while pEC^.GS.loop > 0 do
begin
dec( opargs );
point := pEC^.stack^[ opargs ];
if (point < 0) or (point >= pEC^.zp2.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
Move_Zp2_Point( point, dx, dy );
dec( pEC^.GS.loop );
end;
pEC^.GS.loop := 1;
new_top := opargs;
end;
(**********************************************)
(* MSIRP[a] : Move Stack Indirect Relative *)
(* CodeRange : $3A-$3B *)
procedure TInterpreter.Ins_MSIRP( args : PStorage );
var
point : Int;
distance : TT_F26dot6;
begin
point := args^[0];
if (args^[0] < 0) or (args^[0] >= pEC^.zp1.n_points) then
begin
pEC^.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 pEC^.GS.gep0 = 0 then (* if in twilight zone *)
begin
pEC^.zp1.org^[point] := pEC^.zp0.org^[pEC^.GS.rp0];
pEC^.zp1.cur^[point] := pEC^.zp1.org^[point];
end;
distance := pEC^.func_project( pEC^.zp1.cur^[point],
pEC^.zp0.cur^[pEC^.GS.rp0] );
pEC^.func_move( @pEC^.zp1, point, args^[1] - distance );
pEC^.GS.rp1 := pEC^.GS.rp0;
pEC^.GS.rp2 := point;
if opcode and 1 <> 0 then pEC^.GS.rp0 := point;
end;
(**********************************************)
(* MDAP[a] : Move Direct Absolute Point *)
(* CodeRange : $2E-$2F *)
procedure TInterpreter.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] >= pEC^.zp0.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
(* XXXX Is there some undocumented feature while in the *)
(* twilight zone ?? *)
if opcode and 1 <> 0 then
begin
cur_dist := pEC^.func_project( pEC^.zp0.cur^[point], Null_Vector );
distance := pEC^.func_round( cur_dist,
pEC^.metrics.compensations[0] ) -
cur_dist;
end
else
distance := 0;
pEC^.func_move( @pEC^.zp0, point, distance );
pEC^.GS.rp0 := point;
pEC^.GS.rp1 := point;
end;
(**********************************************)
(* MIAP[a] : Move Indirect Absolute Point *)
(* CodeRange : $3E-$3F *)
procedure TInterpreter.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] >= pEC^.zp0.n_points ) or
(args^[1] < 0) or (args^[1] >= pEC^.cvtSize) then
begin
pEC^.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 := pEC^.func_read_cvt(cvtEntry);
if pEC^.GS.gep0 = 0 then (* If in twilight zone *)
begin
pEC^.zp0.org^[point].y := MulDiv_Round( pEC^.GS.freeVector.x,
distance,
$4000 );
pEC^.zp0.org^[point].y := MulDiv_Round( pEC^.GS.freeVector.y,
distance,
$4000 );
pEC^.zp0.cur^[point] := pEC^.zp0.org^[point];
end;
org_dist := pEC^.func_project( pEC^.zp0.cur^[point], Null_Vector );
if opcode and 1 <> 0 then (* rounding and control cutin flag *)
begin
if abs( distance-org_dist ) > pEC^.GS.control_value_cutin then
distance := org_dist;
distance := pEC^.func_round( distance,
pEC^.metrics.compensations[0] );
end;
pEC^.func_move( @pEC^.zp0, point, distance - org_dist );
pEC^.GS.rp0 := point;
pEC^.GS.rp1 := point;
end;
(**********************************************)
(* MDRP[abcde] : Move Direct Relative Point *)
(* CodeRange : $C0-$DF *)
procedure TInterpreter.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] >= pEC^.zp1.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
(* XXXX Is there some undocumented feature while in the *)
(* twilight zone ?? *)
org_dist := pEC^.func_dualProj( pEC^.zp1.org^[point],
pEC^.zp0.org^[pEC^.GS.rp0] );
(* single width cutin test *)
if abs(org_dist) < pEC^.GS.single_width_cutin then
if org_dist >= 0 then org_dist := pEC^.GS.single_width_value
else org_dist := -pEC^.GS.single_width_value;
(* round flag *)
if opcode and 4 <> 0 then
distance := pEC^.func_round( org_dist,
pEC^.metrics.compensations[ opcode and 3 ] )
else
distance := Round_None( org_dist,
pEC^.metrics.compensations[ opcode and 3 ] );
(* minimum distance flag *)
if opcode and 8 <> 0 then
begin
if org_dist >= 0 then
if distance < pEC^.GS.minimum_distance then
distance := pEC^.GS.minimum_distance
else
else
if distance > -pEC^.GS.minimum_distance then
distance := -pEC^.GS.minimum_distance;
end;
(* now move the point *)
org_dist := pEC^.func_project( pEC^.zp1.cur^[point],
pEC^.zp0.cur^[pEC^.GS.rp0] );
pEC^.func_move( @pEC^.zp1, point, distance - org_dist );
pEC^.GS.rp1 := pEC^.GS.rp0;
pEC^.GS.rp2 := point;
if opcode and 16 <> 0 then pEC^.GS.rp0 := point;
end;
(**********************************************)
(* MIRP[abcde] : Move Indirect Relative Point *)
(* CodeRange : $E0-$FF *)
procedure TInterpreter.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] >= pEC^.zp1.n_points) or
(args^[1] < -1) or (args^[1] >= pEC^.cvtSize) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
if cvtEntry < 0 then
cvt_dist := 0
else
cvt_dist := pEC^.func_read_cvt(cvtEntry);
(* single width test *)
if abs(cvt_dist) < pEC^.GS.single_width_cutin then
if cvt_dist >= 0 then cvt_dist := pEC^.GS.single_width_value
else cvt_dist := -pEC^.GS.single_width_value;
(* XXX : Undocumented - twilight zone *)
if pEC^.GS.gep1 = 0 then (* if in twilight zone *)
begin
pEC^.zp1.org^[point].x := pEC^.zp0.org^[pEC^.GS.rp0].x +
MulDiv_Round( cvt_dist,
pEC^.GS.freeVector.x,
$4000 );
pEC^.zp1.org^[point].x := pEC^.zp0.org^[pEC^.GS.rp0].y +
MulDiv_Round( cvt_dist,
pEC^.GS.freeVector.y,
$4000 );
pEC^.zp1.cur^[point] := pEC^.zp1.org^[point];
end;
org_dist := pEC^.func_dualProj( pEC^.zp1.org^[point],
pEC^.zp0.org^[pEC^.GS.rp0] );
cur_dist := pEC^.func_Project( pEC^.zp1.cur^[point],
pEC^.zp0.cur^[pEC^.GS.rp0] );
(* auto-flip test *)
if pEC^.GS.auto_flip then
if (org_dist xor cvt_dist < 0) then
cvt_dist := -cvt_dist;
(* control value cutin and round *)
if opcode and 4 <> 0 then
begin
(* XXX : UNDOCUMENTED : only perform cut-in test when both *)
(* zone pointers refer to the points zone *)
if pEC^.GS.gep0 = pEC^.GS.gep1 then
if abs( cvt_dist - org_dist ) >= pEC^.GS.control_value_cutin then
cvt_dist := org_dist;
distance := pEC^.func_round( cvt_dist,
pEC^.metrics.compensations[ opcode and 3 ] );
end
else
distance := Round_None( cvt_dist,
pEC^.metrics.compensations[ opcode and 3 ] );
(* minimum distance test *)
if opcode and 8 <> 0 then
begin
if org_dist >= 0 then
if distance < pEC^.GS.minimum_distance then
distance := pEC^.GS.minimum_distance
else
else
if distance > -pEC^.GS.minimum_distance then
distance := -pEC^.GS.minimum_distance;
end;
pEC^.func_move( @pEC^.zp1, point, distance - cur_dist );
pEC^.GS.rp1 := pEC^.GS.rp0;
if opcode and 16 <> 0 then pEC^.GS.rp0 := point;
(* UNDOCUMENTED !! *)
pEC^.GS.rp2 := point;
end;
(**********************************************)
(* ALIGNRP[] : ALIGN Relative Point *)
(* CodeRange : $3C *)
procedure TInterpreter.Ins_ALIGNRP(args : PStorage );
var
point : Int;
distance : TT_F26dot6;
begin
if top < pEC^.GS.loop then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
while pEC^.GS.loop > 0 do
begin
dec( opargs );
point := pEC^.stack^[ opargs ];
if (point < 0) or (point >= pEC^.zp1.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
distance := pEC^.func_project( pEC^.zp1.cur^[point],
pEC^.zp0.cur^[pEC^.GS.rp0] );
pEC^.func_move( @pEC^.zp1, point, -distance );
dec( pEC^.GS.loop );
end;
pEC^.GS.loop := 1;
new_top := opargs;
end;
(**********************************************)
(* AA[] : Adjust Angle *)
(* CodeRange : $7F *)
procedure TInterpreter.Ins_AA( args : PStorage );
begin
(* Intentional - no longer supported *)
end;
(**********************************************)
(* ISECT[] : moves point to InterSECTion *)
(* CodeRange : $0F *)
procedure TInterpreter.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 >= pEC^.zp0.n_points) or (b1 >= pEC^.zp0.n_points) or
(a0 >= pEC^.zp1.n_points) or (a1 >= pEC^.zp1.n_points) or
(point >= pEC^.zp0.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
(*
if Normalize( pEC^.zp1.cur_x^[a1] - pEC^.zp1.cur_x^[a0],
pEC^.zp1.cur_y^[a1] - pEC^.zp1.cur_y^[a0],
U )
and
Normalize( - pEC^.zp0.cur_x^[b1] - pEC^.zp0.cur_x^[b0],
pEC^.zp0.cur_y^[b1] - pEC^.zp0.cur_y^[b0],
V )
then
begin
dx := MulDiv_Round( pEC^.zp0.cur_x^[b0] -
pEC^.zp1.cur_x^[a0],
V.x,
$4000 ) +
MulDiv_Round( pEC^.zp0.cur_y^[b0] -
pEC^.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 );
pEC^.zp2.flags^[point] := pEC^.zp2.flags^[point] or
TT_Flag_Touched_Both;
pEC^.zp2.cur_x^[point] := pEC^.zp1.cur_x^[a0] +
MulDiv_Round( dx, U.x, $4000 );
pEC^.zp2.cur_y^[point] := pEC^.zp1.cur_y^[a0] +
MulDiv_Round( dx, U.y, $4000 );
exit;
end;
end;
*)
dbx := pEC^.zp0.cur^[b1].x - pEC^.zp0.cur^[b0].x;
dby := pEC^.zp0.cur^[b1].y - pEC^.zp0.cur^[b0].y;
dax := pEC^.zp1.cur^[a1].x - pEC^.zp1.cur^[a0].x;
day := pEC^.zp1.cur^[a1].y - pEC^.zp1.cur^[a0].y;
dx := pEC^.zp0.cur^[b0].x - pEC^.zp1.cur^[a0].x;
dy := pEC^.zp0.cur^[b0].y - pEC^.zp1.cur^[a0].y;
pEC^.zp2.flags^[point] := pEC^.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 );
pEC^.zp2.cur^[point].x := pEC^.zp1.cur^[a0].x + R.x;
pEC^.zp2.cur^[point].y := pEC^.zp1.cur^[a0].y + R.y;
end
else
begin
(* else, take the middle of the middles of A and B *)
pEC^.zp2.cur^[point].x := ( pEC^.zp1.cur^[a0].x +
pEC^.zp1.cur^[a1].x +
pEC^.zp0.cur^[b0].x +
pEC^.zp0.cur^[b1].x ) div 4;
pEC^.zp2.cur^[point].y := ( pEC^.zp1.cur^[a0].y +
pEC^.zp1.cur^[a1].y +
pEC^.zp0.cur^[b0].y +
pEC^.zp0.cur^[b1].y ) div 4;
end;
end;
(**********************************************)
(* ALIGNPTS[] : ALIGN PoinTS *)
(* CodeRange : $27 *)
procedure TInterpreter.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] >= pEC^.zp1.n_points) or
(args^[1] < 0) or (args^[1] >= pEC^.zp0.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
distance := pEC^.func_project( pEC^.zp0.cur^[p2],
pEC^.zp1.cur^[p1] ) div 2;
pEC^.func_move( @pEC^.zp1, p1, distance );
pEC^.func_move( @pEC^.zp0, p2, -distance );
end;
(**********************************************)
(* IP[] : Interpolate Point *)
(* CodeRange : $39 *)
procedure TInterpreter.Ins_IP( 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 top < pEC^.GS.loop then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
org_a := pEC^.func_dualProj( pEC^.zp0.org^[pEC^.GS.rp1], Null_Vector );
org_b := pEC^.func_dualProj( pEC^.zp1.org^[pEC^.GS.rp2], Null_Vector );
cur_a := pEC^.func_project( pEC^.zp0.cur^[pEC^.GS.rp1], Null_Vector );
cur_b := pEC^.func_project( pEC^.zp1.cur^[pEC^.GS.rp2], Null_Vector );
while pEC^.GS.loop > 0 do
begin
dec( opargs );
point := pEC^.stack^[ opargs ];
org_x := pEC^.func_dualProj( pEC^.zp2.org^[point], Null_Vector );
cur_x := pEC^.func_project( pEC^.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;
pEC^.func_move( @pEC^.zp2, point, distance );
dec( pEC^.GS.loop );
end;
pEC^.GS.loop := 1;
new_top := opargs;
end;
(**********************************************)
(* UTP[a] : UnTouch Point *)
(* CodeRange : $29 *)
procedure TInterpreter.Ins_UTP( args : PStorage );
var
mask : Byte;
begin
if (args^[0] < 0) or (args^[0] >= pEC^.zp0.n_points) then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
mask := $FF;
if pEC^.GS.freeVector.x <> 0 then mask := mask and not TT_Flag_Touched_X;
if pEC^.GS.freeVector.y <> 0 then mask := mask and not TT_Flag_Touched_Y;
pEC^.zp0.flags^[args^[0]] := pEC^.zp0.flags^[args^[0]] and mask;
end;
(**********************************************)
(* IUP[a] : Interpolate Untouched Points *)
(* CodeRange : $30-$31 *)
procedure TInterpreter.Ins_IUP( 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 := pEC^.pts.org;
curs := pEC^.pts.cur;
case opcode and 1 of
0 : mask := TT_Flag_Touched_Y;
1 : mask := TT_Flag_Touched_X;
end;
with pEC^ 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 TInterpreter.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 opargs < 2 then
begin
pEC^.error := TT_Err_Too_Few_Arguments;
exit;
end;
dec( opargs, 2 );
A := pEC^.stack^[opargs+1];
B := pEC^.stack^[ opargs ];
(* 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 < pEC^.zp0.n_points then
begin
C := ( B and $F0 ) shr 4;
Case opcode of
$5D : ;
$71 : C := C+16;
$72 : C := C+32;
end;
C := C + pEC^.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 pEC^.GS.delta_Shift );
pEC^.func_move( @pEC^.zp0, A, B );
end;
end;
end;
new_top := opargs;
end;
(**********************************************)
(* DELTACn[] : DELTA Exceptions C1, C2, C3 *)
(* CodeRange : $73,$74,$75 *)
procedure TInterpreter.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 opargs < 2 then
begin
pEC^.error := TT_Err_Too_Few_Arguments;
exit;
end;
dec( opargs, 2 );
A := pEC^.stack^[opargs+1];
B := pEC^.stack^[ opargs ];
if A >= pEC^.cvtSize then
begin
pEC^.error := TT_Err_Invalid_Reference;
exit;
end;
C := ( B and $F0 ) shr 4;
Case opcode of
$73 : ;
$74 : C := C+16;
$75 : C := C+32;
end;
C := C + pEC^.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 pEC^.GS.delta_Shift );
pEC^.func_move_cvt( A, B );
end;
end;
new_top := opargs;
end;
(****************************************************************)
(* *)
(* MISC. INSTRUCTIONS *)
(* *)
(****************************************************************)
(***********************************************************)
(* DEBUG[] : DEBUG. Unsupported *)
(* CodeRange : $4F *)
(* NOTE : The original instruction pops a value from the stack *)
procedure TInterpreter.Ins_DEBUG( args : PStorage );
begin
pEC^.error := TT_Err_Debug_Opcode;
end;
(**********************************************)
(* GETINFO[] : GET INFOrmation *)
(* CodeRange : $88 *)
procedure TInterpreter.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 TInterpreter.Ins_UNKNOWN( args : PStorage );
begin
pEC^.error := TT_Err_Invalid_Opcode;
end;
function TInterpreter.GetLastInstruction: string;
begin
result := Instruct_Dispatch[opcode].name;
end;
constructor TInterpreter.Create(AContext: PExec_Context; AEnableLog: boolean);
var numIns: integer;
procedure addIns(AName: string; AFunc: TInstruction_Function);
begin
if numIns < high(Instruct_Dispatch)+1 then
begin
with Instruct_Dispatch[numIns] do
begin
name := AName;
func := AFunc;
end;
inc(numIns);
end else
raise exception.Create('Too much instructions');
end;
begin
pEC := AContext;
enableLog:= AEnableLog;
if enableLog then instructionLog := TStringList.Create;
numIns := low(Instruct_Dispatch);
addIns('SVTCA y', Ins_SVTCA);
addIns('SVTCA x', Ins_SVTCA);
addIns('SPvTCA y', Ins_SPVTCA);
addIns('SPvTCA x', Ins_SPVTCA);
addIns('SFvTCA y', Ins_SFVTCA);
addIns('SFvTCA x', Ins_SFVTCA);
addIns('SPvTL //', Ins_SPVTL);
addIns('SPvTL +', Ins_SPVTL);
addIns('SFvTL //', Ins_SFVTL);
addIns('SFvTL +', Ins_SFVTL);
addIns('SPvFS', Ins_SPVFS);
addIns('SFvFS', Ins_SFVFS);
addIns('GPV', Ins_GPV);
addIns('GFV', Ins_GFV);
addIns('SFvTPv', Ins_SFVTPV);
addIns('ISECT', Ins_ISECT);
addIns('SRP0', Ins_SRP0);
addIns('SRP1', Ins_SRP1);
addIns('SRP2', Ins_SRP2);
addIns('SZP0', Ins_SZP0);
addIns('SZP1', Ins_SZP1);
addIns('SZP2', Ins_SZP2);
addIns('SZPS', Ins_SZPS);
addIns('SLOOP', Ins_SLOOP);
addIns('RTG', Ins_RTG);
addIns('RTHG', Ins_RTHG);
addIns('SMD', Ins_SMD);
addIns('ELSE', Ins_ELSE);
addIns('JMPR', Ins_JMPR);
addIns('SCvTCi', Ins_SCVTCI);
addIns('SSwCi', Ins_SSWCI);
addIns('SSW', Ins_SSW);
addIns('DUP', Ins_DUP);
addIns('POP', Ins_POP);
addIns('CLEAR', Ins_CLEAR);
addIns('SWAP', Ins_SWAP);
addIns('DEPTH', Ins_DEPTH);
addIns('CINDEX', Ins_CINDEX);
addIns('MINDEX', Ins_MINDEX);
addIns('AlignPTS', Ins_ALIGNPTS);
addIns('INS_$28', Ins_UNKNOWN);
addIns('UTP', Ins_UTP);
addIns('LOOPCALL', Ins_LOOPCALL);
addIns('CALL', Ins_CALL);
addIns('FDEF', Ins_FDEF);
addIns('ENDF', Ins_ENDF);
addIns('MDAP[0]', Ins_MDAP);
addIns('MDAP[1]', Ins_MDAP);
addIns('IUP[0]', Ins_IUP);
addIns('IUP[1]', Ins_IUP);
addIns('SHP[0]', Ins_SHP);
addIns('SHP[1]', Ins_SHP);
addIns('SHC[0]', Ins_SHC);
addIns('SHC[1]', Ins_SHC);
addIns('SHZ[0]', Ins_SHZ);
addIns('SHZ[1]', Ins_SHZ);
addIns('SHPIX', Ins_SHPIX);
addIns('IP', Ins_IP);
addIns('MSIRP[0]', Ins_MSIRP);
addIns('MSIRP[1]', Ins_MSIRP);
addIns('AlignRP', Ins_ALIGNRP);
addIns('RTDG', Ins_RTDG);
addIns('MIAP[0]', Ins_MIAP);
addIns('MIAP[1]', Ins_MIAP);
addIns('NPushB', Ins_NPUSHB);
addIns('NPushW', Ins_NPUSHW);
addIns('WS', Ins_WS);
addIns('RS', Ins_RS);
addIns('WCvtP', Ins_WCVTP);
addIns('RCvt', Ins_RCVT);
addIns('GC[0]', Ins_GC);
addIns('GC[1]', Ins_GC);
addIns('SCFS', Ins_SCFS);
addIns('MD[0]', Ins_MD);
addIns('MD[1]', Ins_MD);
addIns('MPPEM', Ins_MPPEM);
addIns('MPS', Ins_MPS);
addIns('FlipON', Ins_FLIPON);
addIns('FlipOFF', Ins_FLIPOFF);
addIns('DEBUG', Ins_DEBUG);
addIns('LT', Ins_LT);
addIns('LTEQ', Ins_LTEQ);
addIns('GT', Ins_GT);
addIns('GTEQ', Ins_GTEQ);
addIns('EQ', Ins_EQ);
addIns('NEQ', Ins_NEQ);
addIns('ODD', Ins_ODD);
addIns('EVEN', Ins_EVEN);
addIns('IF', Ins_IF);
addIns('EIF', Ins_EIF);
addIns('AND', Ins_AND);
addIns('OR', Ins_OR);
addIns('NOT', Ins_NOT);
addIns('DeltaP1', Ins_DELTAP);
addIns('SDB', Ins_SDB);
addIns('SDS', Ins_SDS);
addIns('ADD', Ins_ADD);
addIns('SUB', Ins_SUB);
addIns('DIV', Ins_DIV);
addIns('MUL', Ins_MUL);
addIns('ABS', Ins_ABS);
addIns('NEG', Ins_NEG);
addIns('FLOOR', Ins_FLOOR);
addIns('CEILING', Ins_CEILING);
addIns('ROUND[0]', Ins_ROUND);
addIns('ROUND[1]', Ins_ROUND);
addIns('ROUND[2]', Ins_ROUND);
addIns('ROUND[3]', Ins_ROUND);
addIns('NROUND[0]', Ins_ROUND);
addIns('NROUND[1]', Ins_ROUND);
addIns('NROUND[2]', Ins_ROUND);
addIns('NROUND[3]', Ins_ROUND);
addIns('WCvtF', Ins_WCVTF);
addIns('DeltaP2', Ins_DELTAP);
addIns('DeltaP3', Ins_DELTAP);
addIns('DeltaCn[0]', Ins_DELTAC);
addIns('DeltaCn[1]', Ins_DELTAC);
addIns('DeltaCn[2]', Ins_DELTAC);
addIns('SROUND', Ins_SROUND);
addIns('S45Round', Ins_S45ROUND);
addIns('JROT', Ins_JROT);
addIns('JROF', Ins_JROF);
addIns('ROFF', Ins_ROFF);
addIns('INS_$7B', Ins_UNKNOWN);
addIns('RUTG', Ins_RUTG);
addIns('RDTG', Ins_RDTG);
addIns('SANGW', Ins_SANGW);
addIns('AA', Ins_AA);
addIns('FlipPT', Ins_FLIPPT);
addIns('FlipRgON', Ins_FLIPRGON);
addIns('FlipRgOFF', Ins_FLIPRGOFF);
addIns('INS_$83', Ins_UNKNOWN);
addIns('INS_$84', Ins_UNKNOWN);
addIns('ScanCTRL', Ins_SCANCTRL);
addIns('SDPVTL[0]', Ins_SDPVTL);
addIns('SDPVTL[1]', Ins_SDPVTL);
addIns('GetINFO', Ins_GETINFO);
addIns('IDEF', Ins_IDEF);
addIns('ROLL', Ins_ROLL);
addIns('MAX', Ins_MAX);
addIns('MIN', Ins_MIN);
addIns('ScanTYPE', Ins_SCANTYPE);
addIns('InstCTRL', Ins_INSTCTRL);
addIns('INS_$8F', Ins_UNKNOWN);
addIns('INS_$90', Ins_UNKNOWN);
addIns('INS_$91', Ins_UNKNOWN);
addIns('INS_$92', Ins_UNKNOWN);
addIns('INS_$93', Ins_UNKNOWN);
addIns('INS_$94', Ins_UNKNOWN);
addIns('INS_$95', Ins_UNKNOWN);
addIns('INS_$96', Ins_UNKNOWN);
addIns('INS_$97', Ins_UNKNOWN);
addIns('INS_$98', Ins_UNKNOWN);
addIns('INS_$99', Ins_UNKNOWN);
addIns('INS_$9A', Ins_UNKNOWN);
addIns('INS_$9B', Ins_UNKNOWN);
addIns('INS_$9C', Ins_UNKNOWN);
addIns('INS_$9D', Ins_UNKNOWN);
addIns('INS_$9E', Ins_UNKNOWN);
addIns('INS_$9F', Ins_UNKNOWN);
addIns('INS_$A0', Ins_UNKNOWN);
addIns('INS_$A1', Ins_UNKNOWN);
addIns('INS_$A2', Ins_UNKNOWN);
addIns('INS_$A3', Ins_UNKNOWN);
addIns('INS_$A4', Ins_UNKNOWN);
addIns('INS_$A5', Ins_UNKNOWN);
addIns('INS_$A6', Ins_UNKNOWN);
addIns('INS_$A7', Ins_UNKNOWN);
addIns('INS_$A8', Ins_UNKNOWN);
addIns('INS_$A9', Ins_UNKNOWN);
addIns('INS_$AA', Ins_UNKNOWN);
addIns('INS_$AB', Ins_UNKNOWN);
addIns('INS_$AC', Ins_UNKNOWN);
addIns('INS_$AD', Ins_UNKNOWN);
addIns('INS_$AE', Ins_UNKNOWN);
addIns('INS_$AF', Ins_UNKNOWN);
addIns('PushB[0]', Ins_PUSHB);
addIns('PushB[1]', Ins_PUSHB);
addIns('PushB[2]', Ins_PUSHB);
addIns('PushB[3]', Ins_PUSHB);
addIns('PushB[4]', Ins_PUSHB);
addIns('PushB[5]', Ins_PUSHB);
addIns('PushB[6]', Ins_PUSHB);
addIns('PushB[7]', Ins_PUSHB);
addIns('PushW[0]', Ins_PUSHW);
addIns('PushW[1]', Ins_PUSHW);
addIns('PushW[2]', Ins_PUSHW);
addIns('PushW[3]', Ins_PUSHW);
addIns('PushW[4]', Ins_PUSHW);
addIns('PushW[5]', Ins_PUSHW);
addIns('PushW[6]', Ins_PUSHW);
addIns('PushW[7]', Ins_PUSHW);
addIns('MDRP[00]', Ins_MDRP);
addIns('MDRP[01]', Ins_MDRP);
addIns('MDRP[02]', Ins_MDRP);
addIns('MDRP[03]', Ins_MDRP);
addIns('MDRP[04]', Ins_MDRP);
addIns('MDRP[05]', Ins_MDRP);
addIns('MDRP[06]', Ins_MDRP);
addIns('MDRP[07]', Ins_MDRP);
addIns('MDRP[08]', Ins_MDRP);
addIns('MDRP[09]', Ins_MDRP);
addIns('MDRP[10]', Ins_MDRP);
addIns('MDRP[11]', Ins_MDRP);
addIns('MDRP[12]', Ins_MDRP);
addIns('MDRP[13]', Ins_MDRP);
addIns('MDRP[14]', Ins_MDRP);
addIns('MDRP[15]', Ins_MDRP);
addIns('MDRP[16]', Ins_MDRP);
addIns('MDRP[17]', Ins_MDRP);
addIns('MDRP[18]', Ins_MDRP);
addIns('MDRP[19]', Ins_MDRP);
addIns('MDRP[20]', Ins_MDRP);
addIns('MDRP[21]', Ins_MDRP);
addIns('MDRP[22]', Ins_MDRP);
addIns('MDRP[23]', Ins_MDRP);
addIns('MDRP[24]', Ins_MDRP);
addIns('MDRP[25]', Ins_MDRP);
addIns('MDRP[26]', Ins_MDRP);
addIns('MDRP[27]', Ins_MDRP);
addIns('MDRP[28]', Ins_MDRP);
addIns('MDRP[29]', Ins_MDRP);
addIns('MDRP[30]', Ins_MDRP);
addIns('MDRP[31]', Ins_MDRP);
addIns('MIRP[00]', Ins_MIRP);
addIns('MIRP[01]', Ins_MIRP);
addIns('MIRP[02]', Ins_MIRP);
addIns('MIRP[03]', Ins_MIRP);
addIns('MIRP[04]', Ins_MIRP);
addIns('MIRP[05]', Ins_MIRP);
addIns('MIRP[06]', Ins_MIRP);
addIns('MIRP[07]', Ins_MIRP);
addIns('MIRP[08]', Ins_MIRP);
addIns('MIRP[09]', Ins_MIRP);
addIns('MIRP[10]', Ins_MIRP);
addIns('MIRP[11]', Ins_MIRP);
addIns('MIRP[12]', Ins_MIRP);
addIns('MIRP[13]', Ins_MIRP);
addIns('MIRP[14]', Ins_MIRP);
addIns('MIRP[15]', Ins_MIRP);
addIns('MIRP[16]', Ins_MIRP);
addIns('MIRP[17]', Ins_MIRP);
addIns('MIRP[18]', Ins_MIRP);
addIns('MIRP[19]', Ins_MIRP);
addIns('MIRP[20]', Ins_MIRP);
addIns('MIRP[21]', Ins_MIRP);
addIns('MIRP[22]', Ins_MIRP);
addIns('MIRP[23]', Ins_MIRP);
addIns('MIRP[24]', Ins_MIRP);
addIns('MIRP[25]', Ins_MIRP);
addIns('MIRP[26]', Ins_MIRP);
addIns('MIRP[27]', Ins_MIRP);
addIns('MIRP[28]', Ins_MIRP);
addIns('MIRP[29]', Ins_MIRP);
addIns('MIRP[30]', Ins_MIRP);
addIns('MIRP[31]', Ins_MIRP);
if numIns <> high(Instruct_Dispatch)+1 then
raise exception.Create('Missing instruction');
end;
destructor TInterpreter.Destroy;
begin
instructionLog.Free;
inherited Destroy;
end;
function TInterpreter.Run: TError;
label
SuiteLabel, ErrorLabel, No_Error;
var
A : Int;
begin
top := 0;
callTop := 0;
if enableLog then instructionLog.Clear;
(* set cvt functions *)
pEC^.metrics.ratio := 0;
if pEC^.instance^.metrics.x_ppem <> pEC^.instance^.metrics.y_ppem then
begin
pEC^.func_read_cvt := Read_CVT_Stretched;
pEC^.func_write_cvt := Write_CVT_Stretched;
pEC^.func_move_cvt := Move_CVT_Stretched;
end
else
begin
pEC^.func_read_cvt := Read_CVT;
pEC^.func_write_cvt := Write_CVT;
pEC^.func_move_cvt := Move_CVT;
end;
Compute_Funcs;
Compute_Round( pEC^.GS.round_state );
repeat
Calc_Length;
(* First, let's check for empty stack and overflow *)
opargs := top - Pop_Push_Count[ 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 opargs < 0 then
begin
pEC^.error := TT_Err_Too_Few_Arguments;
goto ErrorLabel;
end;
new_top := opargs + Pop_Push_Count[ 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 NeedStackSize(new_top) then goto ErrorLabel;
pEC^.step_ins := true;
pEC^.error := TT_Err_Ok;
if enableLog then instructionLog.Add('0x'+IntToHex(pEC^.IP,4)+': '+Instruct_Dispatch[ opcode ].name + ' (SP=' + IntToStr(top)+')');
Instruct_Dispatch[ opcode ].func( PStorage(@pEC^.stack^[opargs]) );
if pEC^.error <> TT_Err_Ok then
begin
case pEC^.error of
TT_Err_Invalid_Opcode: (* looking for redefined instructions *)
begin
A := 0;
while ( A < pEC^.numIDefs ) do
with pEC^.IDefs^[A] do
if Active and ( opcode = Opc ) then
begin
if callTop >= pEC^.callSize then
begin
pEC^.error := TT_Err_Invalid_Reference;
goto ErrorLabel;
end;
with pEC^.callstack^[callTop] do
begin
Caller_Range := pEC^.curRange;
Caller_IP := pEC^.IP+1;
Cur_Count := 1;
Cur_Restart := Start;
end;
if not Goto_CodeRange( Range, Start ) then
goto ErrorLabel;
goto SuiteLabel;
end
else
inc(A);
pEC^.error := TT_Err_Invalid_Opcode;
goto ErrorLabel;
end;
else
pEC^.error := pEC^.error;
goto ErrorLabel;
end;
end;
top := new_top;
if pEC^.step_ins then inc( pEC^.IP, oplength );
SuiteLabel:
if (pEC^.IP >= pEC^.codeSize) then
if callTop > 0 then
begin
pEC^.error := TT_Err_Code_Overflow;
goto ErrorLabel;
end
else
goto No_Error;
until pEC^.instruction_trap;
No_Error:
result := Success;
exit;
ErrorLabel:
result := Failure;
end;
function TInterpreter.NeedStackSize(AValue: integer): TError;
var newSize: integer;
newStack: PStorage;
begin
if AValue > pEC^.stackSize then
begin
if pEC^.stackSize < maxStackSizeAllowed then
begin
newSize := pEC^.stackSize*2+1;
if newSize > maxStackSizeAllowed then newSize := maxStackSizeAllowed;
newStack := nil;
if Alloc( newStack, newSize*sizeof(Long) ) then
begin //cannot allocate
pEC^.error := TT_Err_Stack_Overflow;
result := Failure;
end;
move(pEC^.stack^[0], newStack^[0], pEC^.stackSize*sizeof(Long) );
TTMemory.Free( pEC^.stack );
pEC^.stack := newStack;
pEC^.stackSize := newSize;
result := Success; //stack expanded
end else
begin
//maximum allowed reached
pEC^.error := TT_Err_Stack_Overflow;
result := Failure;
end;
end else
result := Success;
end;
function TInterpreter.NeedStackSize(AValue: integer;
var APointerInStack: PStorage): TError;
var APosInStack: integer;
begin
if (APointerInStack <> nil) then
begin
APosInStack:= System.PByte(APointerInStack) - System.PByte(pEC^.stack);
result := NeedStackSize(AValue);
APointerInStack := PStorage(System.PByte(pEC^.stack) + APosInStack);
end else
result := NeedStackSize(AValue);
end;
(****************************************************************)
(* *)
(* 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; AErrorLog: boolean ) : TError;
var interpreter: TInterpreter;
logfile: TFileStream;
procedure writelnLog(s: string);
begin
s+= LineEnding;
logfile.WriteBuffer(s[1],length(s));
end;
begin
if exec.interpreter = nil then
begin
interpreter := TInterpreter.Create(exec,AErrorLog);
exec.interpreter := interpreter;
end else
interpreter := TInterpreter(exec.interpreter);
result := interpreter.Run;
if AErrorLog and result then
begin
logfile := TFileStream.Create('ttinterp.log',fmOpenWrite or fmCreate);
writelnLog('----------------------- '+DateTimeToStr(Now));
writelnLog('Error ' + IntToHex(exec.error,4) + ' on ' + interpreter.LastInstruction);
writelnLog('Program:');
interpreter.instructionLog.SaveToStream(logfile);
writelnLog('-----------------------');
logfile.Free;
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink