pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
applications
bindings
components
Comba_Animation
aboutcomponent
acs
beepfp
callite
captcha
chelper
chemtext
cmdline
cmdlinecfg
colorpalette
cryptini
csvdocument
epiktimer
everettrandom
examplecomponent
exctrls
extrasyn
fpexif
fpsound
fpspreadsheet
fractions
freetypepascal
freetype.pas
lazfreetype.lpk
lazfreetype.pas
ttcache.pas
ttcalc.pas
ttcalc1.inc
ttcalc2.inc
ttcalc3.inc
ttcalc4.inc
ttcmap.pas
ttconfig.inc
ttdebug.pas
tterror.pas
ttfile.pas
ttgload.pas
ttinterp.pas
ttload.pas
ttmemory.pas
ttobjs.pas
ttraster.pas
tttables.pas
tttypes.pas
geckoport
gradcontrols
grid_semaphor
gridprinter
industrialstuff
iosdesigner
iphonelazext
jujiboutils
jvcllaz
kcontrols
lazautoupdate
lazbarcodes
lazmapviewer
lclextensions
longtimer
manualdock
mbColorLib
mplayer
multithreadprocs
nicechart
nicegrid
nicesidebar
nvidia-widgets
onguard
orpheus
playsoundpackage
poweredby
powerpdf
rgbgraphics
richmemo
richview
rtfview
rx
scrolltext
smnetgradient
spktoolbar
splashabout
svn
systools
tdi
thtmlport
tparadoxdataset
tvplanit
xdev_toolkit
zlibar
zmsql
examples
image_sources
lclbindings
wst
b659d15d6abc9f9a8dc28a50abe72a3b44eca380
lazarus-ccr/components/freetypepascal/ttinterp.pas
sekelsenmat 9e2f90802b Fixes compilation of freetype 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1566 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2011-04-12 09:00:36 +00:00

4801 lines
132 KiB
ObjectPascal
Raw Blame History

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