(******************************************************************* * * 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 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 ); 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 FPK} 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 FPK} 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 FPK} func_freeProj := @Project_y; {$ELSE} func_freeProj := Project_y; {$ENDIF} F_dot_P := Long(projVector.y) * $10000; end else begin {$IFDEF FPK} 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 FPK} 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 FPK} 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 FPK} 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 FPK} 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 FPK} 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 FPK} 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 FPK} 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 FPK} 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 FPK} 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 FPK} 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.