?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
contrib/OWB: add correct SDL dependency, fix compilers used
[AROS-Contrib.git] / freetype1 / pascal / lib / ttinterp.pas
blob4d82e99c3a8de439218f67125da278d6ad2e6a7e
1 (*******************************************************************
2 *
3 * TTInterp.pas 2.0
4 *
5 * TrueType bytecode intepreter.
6 *
7 * Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
8 *
9 * This file is part of the FreeType project, and may only be used
10 * modified and distributed under the terms of the FreeType project
11 * license, LICENSE.TXT. By continuing to use, modify or distribute
12 * this file you indicate that you have read the license and
13 * understand and accept it fully.
14 *
15 *
16 * Changes between 2.0 and 1.2 :
17 *
18 * - Lots, lots, of changes : This version is not re-entrant,
19 * but much faster.
20 *
21 *
22 ******************************************************************)
23
24 unit TTInterp;
25
26 interface
27
28 uses FreeType,
29 TTTypes,
30 TTObjs;
31
32 function Run_Ins( exec : PExec_Context ) : Boolean;
33 (* Run the interpreter with the current code range and IP *)
34
35 implementation
36 uses
37 TTError,
38 TTMemory,
39 TTCalc;
40
41 type
42 TInstruction_Function = procedure( args : PStorage );
43
44 const
45 Null_Vector : TT_Vector = (x:0;y:0);
46
47 var
48 exc : TExec_Context; (* static variable *)
49
50 const
51
52 (*********************************************************************)
53 (* *)
54 (* Before an opcode is executed, the interpreter verifies that *)
55 (* there are enough arguments on the stack, with the help of *)
56 (* the Pop_Push_Count table. *)
57 (* *)
58 (* Note that for opcodes with a varying numbre of parameters, *)
59 (* either 0 or 1 arg is verified before execution, depending *)
60 (* on the nature of the instruction : *)
61 (* *)
62 (* - if the number of arguments is given by the bytecode *)
63 (* stream or the loop variable, 0 is chosen. *)
64 (* *)
65 (* - if the first argument is a count n that is followed *)
66 (* by arguments a1..an, then 1 is chosen. *)
67 (* *)
68 (*********************************************************************)
69
70 Pop_Push_Count : array[0..511] of byte
71 = (
72 (* SVTCA y *) 0, 0,
73 (* SVTCA x *) 0, 0,
74 (* SPvTCA y *) 0, 0,
75 (* SPvTCA x *) 0, 0,
76 (* SFvTCA y *) 0, 0,
77 (* SFvTCA x *) 0, 0,
78 (* SPvTL // *) 2, 0,
79 (* SPvTL + *) 2, 0,
80 (* SFvTL // *) 2, 0,
81 (* SFvTL + *) 2, 0,
82 (* SPvFS *) 2, 0,
83 (* SFvFS *) 2, 0,
84 (* GPV *) 0, 2,
85 (* GFV *) 0, 2,
86 (* SFvTPv *) 0, 0,
87 (* ISECT *) 5, 0,
88
89 (* SRP0 *) 1, 0,
90 (* SRP1 *) 1, 0,
91 (* SRP2 *) 1, 0,
92 (* SZP0 *) 1, 0,
93 (* SZP1 *) 1, 0,
94 (* SZP2 *) 1, 0,
95 (* SZPS *) 1, 0,
96 (* SLOOP *) 1, 0,
97 (* RTG *) 0, 0,
98 (* RTHG *) 0, 0,
99 (* SMD *) 1, 0,
100 (* ELSE *) 0, 0,
101 (* JMPR *) 1, 0,
102 (* SCvTCi *) 1, 0,
103 (* SSwCi *) 1, 0,
104 (* SSW *) 1, 0,
105
106 (* DUP *) 1, 2,
107 (* POP *) 1, 0,
108 (* CLEAR *) 0, 0,
109 (* SWAP *) 2, 2,
110 (* DEPTH *) 0, 1,
111 (* CINDEX *) 1, 1,
112 (* MINDEX *) 1, 0, (* first arg *)
113 (* AlignPTS *) 2, 0,
114 (* INS_$28 *) 0, 0,
115 (* UTP *) 1, 0,
116 (* LOOPCALL *) 2, 0,
117 (* CALL *) 1, 0,
118 (* FDEF *) 1, 0,
119 (* ENDF *) 0, 0,
120 (* MDAP[0] *) 1, 0,
121 (* MDAP[1] *) 1, 0,
122
123 (* IUP[0] *) 0, 0,
124 (* IUP[1] *) 0, 0,
125 (* SHP[0] *) 0, 0, (* no args *)
126 (* SHP[1] *) 0, 0, (* no args *)
127 (* SHC[0] *) 1, 0,
128 (* SHC[1] *) 1, 0,
129 (* SHZ[0] *) 1, 0,
130 (* SHZ[1] *) 1, 0,
131 (* SHPIX *) 1, 0, (* first arg *)
132 (* IP *) 0, 0, (* no args *)
133 (* MSIRP[0] *) 2, 0,
134 (* MSIRP[1] *) 2, 0,
135 (* AlignRP *) 0, 0, (* no args *)
136 (* RTDG *) 0, 0,
137 (* MIAP[0] *) 2, 0,
138 (* MIAP[1] *) 2, 0,
139
140 (* NPushB *) 0, 0,
141 (* NPushW *) 0, 0,
142 (* WS *) 2, 0,
143 (* RS *) 1, 1,
144 (* WCvtP *) 2, 0,
145 (* RCvt *) 1, 1,
146 (* GC[0] *) 1, 1,
147 (* GC[1] *) 1, 1,
148 (* SCFS *) 2, 0,
149 (* MD[0] *) 2, 1,
150 (* MD[1] *) 2, 1,
151 (* MPPEM *) 0, 1,
152 (* MPS *) 0, 1,
153 (* FlipON *) 0, 0,
154 (* FlipOFF *) 0, 0,
155 (* DEBUG *) 1, 0,
156
157 (* LT *) 2, 1,
158 (* LTEQ *) 2, 1,
159 (* GT *) 2, 1,
160 (* GTEQ *) 2, 1,
161 (* EQ *) 2, 1,
162 (* NEQ *) 2, 1,
163 (* ODD *) 1, 1,
164 (* EVEN *) 1, 1,
165 (* IF *) 1, 0,
166 (* EIF *) 0, 0,
167 (* AND *) 2, 1,
168 (* OR *) 2, 1,
169 (* NOT *) 1, 1,
170 (* DeltaP1 *) 1, 0, (* first arg *)
171 (* SDB *) 1, 0,
172 (* SDS *) 1, 0,
173
174 (* ADD *) 2, 1,
175 (* SUB *) 2, 1,
176 (* DIV *) 2, 1,
177 (* MUL *) 2, 1,
178 (* ABS *) 1, 1,
179 (* NEG *) 1, 1,
180 (* FLOOR *) 1, 1,
181 (* CEILING *) 1, 1,
182 (* ROUND[0] *) 1, 1,
183 (* ROUND[1] *) 1, 1,
184 (* ROUND[2] *) 1, 1,
185 (* ROUND[3] *) 1, 1,
186 (* NROUND[0]*) 1, 1,
187 (* NROUND[1]*) 1, 1,
188 (* NROUND[2]*) 1, 1,
189 (* NROUND[3]*) 1, 1,
190
191 (* WCvtF *) 2, 0,
192 (* DeltaP2 *) 1, 0, (* first arg *)
193 (* DeltaP3 *) 1, 0, (* first arg *)
194 (* DeltaCn[0]*) 1, 0, (* first arg *)
195 (* DeltaCn[1]*) 1, 0, (* first arg *)
196 (* DeltaCn[2]*) 1, 0, (* first arg *)
197 (* SROUND *) 1, 0,
198 (* S45Round *) 1, 0,
199 (* JROT *) 2, 0,
200 (* JROF *) 2, 0,
201 (* ROFF *) 0, 0,
202 (* INS_$7B *) 0, 0,
203 (* RUTG *) 0, 0,
204 (* RDTG *) 0, 0,
205 (* SANGW *) 1, 0,
206 (* AA *) 1, 0,
207
208 (* FlipPT *) 0, 0, (* no args *)
209 (* FlipRgON *) 2, 0,
210 (* FlipRgOFF*) 2, 0,
211 (* INS_$83 *) 0, 0,
212 (* INS_$84 *) 0, 0,
213 (* ScanCTRL *) 1, 0,
214 (* SDVPTL[0]*) 2, 0,
215 (* SDVPTL[1]*) 2, 0,
216 (* GetINFO *) 1, 1,
217 (* IDEF *) 1, 0,
218 (* ROLL *) 3, 3, (* pops 3 args/push 3 args *)
219 (* MAX *) 2, 1,
220 (* MIN *) 2, 1,
221 (* ScanTYPE *) 1, 0,
222 (* InstCTRL *) 2, 0,
223 (* INS_$8F *) 0, 0,
224
225 (* INS_$90 *) 0, 0,
226 (* INS_$91 *) 0, 0,
227 (* INS_$92 *) 0, 0,
228 (* INS_$93 *) 0, 0,
229 (* INS_$94 *) 0, 0,
230 (* INS_$95 *) 0, 0,
231 (* INS_$96 *) 0, 0,
232 (* INS_$97 *) 0, 0,
233 (* INS_$98 *) 0, 0,
234 (* INS_$99 *) 0, 0,
235 (* INS_$9A *) 0, 0,
236 (* INS_$9B *) 0, 0,
237 (* INS_$9C *) 0, 0,
238 (* INS_$9D *) 0, 0,
239 (* INS_$9E *) 0, 0,
240 (* INS_$9F *) 0, 0,
241
242 (* INS_$A0 *) 0, 0,
243 (* INS_$A1 *) 0, 0,
244 (* INS_$A2 *) 0, 0,
245 (* INS_$A3 *) 0, 0,
246 (* INS_$A4 *) 0, 0,
247 (* INS_$A5 *) 0, 0,
248 (* INS_$A6 *) 0, 0,
249 (* INS_$A7 *) 0, 0,
250 (* INS_$A8 *) 0, 0,
251 (* INS_$A9 *) 0, 0,
252 (* INS_$AA *) 0, 0,
253 (* INS_$AB *) 0, 0,
254 (* INS_$AC *) 0, 0,
255 (* INS_$AD *) 0, 0,
256 (* INS_$AE *) 0, 0,
257 (* INS_$AF *) 0, 0,
258
259 (* PushB[0] *) 0, 1,
260 (* PushB[1] *) 0, 2,
261 (* PushB[2] *) 0, 3,
262 (* PushB[3] *) 0, 4,
263 (* PushB[4] *) 0, 5,
264 (* PushB[5] *) 0, 6,
265 (* PushB[6] *) 0, 7,
266 (* PushB[7] *) 0, 8,
267 (* PushW[0] *) 0, 1,
268 (* PushW[1] *) 0, 2,
269 (* PushW[2] *) 0, 3,
270 (* PushW[3] *) 0, 4,
271 (* PushW[4] *) 0, 5,
272 (* PushW[5] *) 0, 6,
273 (* PushW[6] *) 0, 7,
274 (* PushW[7] *) 0, 8,
275
276 (* MDRP[00] *) 1, 0,
277 (* MDRP[01] *) 1, 0,
278 (* MDRP[02] *) 1, 0,
279 (* MDRP[03] *) 1, 0,
280 (* MDRP[04] *) 1, 0,
281 (* MDRP[05] *) 1, 0,
282 (* MDRP[06] *) 1, 0,
283 (* MDRP[07] *) 1, 0,
284 (* MDRP[08] *) 1, 0,
285 (* MDRP[09] *) 1, 0,
286 (* MDRP[10] *) 1, 0,
287 (* MDRP[11] *) 1, 0,
288 (* MDRP[12] *) 1, 0,
289 (* MDRP[13] *) 1, 0,
290 (* MDRP[14] *) 1, 0,
291 (* MDRP[15] *) 1, 0,
292 (* MDRP[16] *) 1, 0,
293 (* MDRP[17] *) 1, 0,
294
295 (* MDRP[18] *) 1, 0,
296 (* MDRP[19] *) 1, 0,
297 (* MDRP[20] *) 1, 0,
298 (* MDRP[21] *) 1, 0,
299 (* MDRP[22] *) 1, 0,
300 (* MDRP[23] *) 1, 0,
301 (* MDRP[24] *) 1, 0,
302 (* MDRP[25] *) 1, 0,
303 (* MDRP[26] *) 1, 0,
304 (* MDRP[27] *) 1, 0,
305 (* MDRP[28] *) 1, 0,
306 (* MDRP[29] *) 1, 0,
307 (* MDRP[30] *) 1, 0,
308 (* MDRP[31] *) 1, 0,
309
310 (* MIRP[00] *) 2, 0,
311 (* MIRP[01] *) 2, 0,
312 (* MIRP[02] *) 2, 0,
313 (* MIRP[03] *) 2, 0,
314 (* MIRP[04] *) 2, 0,
315 (* MIRP[05] *) 2, 0,
316 (* MIRP[06] *) 2, 0,
317 (* MIRP[07] *) 2, 0,
318 (* MIRP[08] *) 2, 0,
319 (* MIRP[09] *) 2, 0,
320 (* MIRP[10] *) 2, 0,
321 (* MIRP[11] *) 2, 0,
322 (* MIRP[12] *) 2, 0,
323 (* MIRP[13] *) 2, 0,
324 (* MIRP[14] *) 2, 0,
325 (* MIRP[15] *) 2, 0,
326 (* MIRP[16] *) 2, 0,
327 (* MIRP[17] *) 2, 0,
328
329 (* MIRP[18] *) 2, 0,
330 (* MIRP[19] *) 2, 0,
331 (* MIRP[20] *) 2, 0,
332 (* MIRP[21] *) 2, 0,
333 (* MIRP[22] *) 2, 0,
334 (* MIRP[23] *) 2, 0,
335 (* MIRP[24] *) 2, 0,
336 (* MIRP[25] *) 2, 0,
337 (* MIRP[26] *) 2, 0,
338 (* MIRP[27] *) 2, 0,
339 (* MIRP[28] *) 2, 0,
340 (* MIRP[29] *) 2, 0,
341 (* MIRP[30] *) 2, 0,
342 (* MIRP[31] *) 2, 0
343 );
344
345
346 (*******************************************************************
347 *
348 * Function : Norm
349 *
350 * Description : returns the norm (length) of a vector
351 *
352 * Input : X, Y vector
353 *
354 * Output : returns length in F26dot6
355 *
356 *****************************************************************)
357
358 function Norm( X, Y : TT_F26dot6 ): TT_F26dot6;
359 var
360 T1, T2 : Int64;
361 begin
362 MulTo64( X, X, T1 );
363 MulTo64( Y, Y, T2 );
364
365 Add64( T1, T2, T1 );
366
367 if ( (T1.lo or T1.Hi) = 0 ) then Norm := 0
368 else Norm := Sqrt64( T1 );
369 end;
370
371 (*******************************************************************
372 *
373 * Function : Scale_Pixels
374 *
375 * Description : Converts from FUnits to Fractional pixels
376 * coordinates.
377 *
378 *****************************************************************)
379
380 function Scale_Pixels( value : long ) : TT_F26Dot6;
381 {$IFDEF INLINE} inline; {$ENDIF}
382 begin
383 Scale_Pixels := MulDiv_Round( value,
384 exc.metrics.scale1,
385 exc.metrics.scale2 );
386 end;
387
388 function Get_Current_Ratio : Long;
389 var
390 x, y : Long;
391 begin
392 if exc.metrics.ratio <> 0 then
393 Get_Current_Ratio := exc.metrics.ratio
394 else
395 begin
396 if exc.GS.projVector.y = 0 then
397 exc.metrics.ratio := exc.metrics.x_ratio
398
399 else if exc.GS.projVector.x = 0 then
400 exc.metrics.ratio := exc.metrics.y_ratio
401
402 else
403 begin
404 x := MulDiv_Round( exc.GS.projVector.x,
405 exc.metrics.x_ratio,
406 $4000 );
407
408 y := MulDiv_Round( exc.GS.projVector.y,
409 exc.metrics.y_ratio,
410 $4000 );
411
412 exc.metrics.ratio := Norm( x, y );
413 end;
414
415 Get_Current_Ratio := exc.metrics.ratio;
416 end
417 end;
418
419 function Get_Ppem : Long;
420 {$IFDEF INLINE} inline; {$ENDIF}
421 begin
422 Get_Ppem := MulDiv_Round( exc.metrics.ppem, Get_Current_Ratio, $10000 );
423 end;
424
425
426 function Read_CVT( index : Int ) : TT_F26Dot6;
427 {$IFNDEF FPK} far; {$ENDIF}
428 begin
429 Read_CVT := exc.cvt^[index];
430 end;
431
432 function Read_CVT_Stretched( index : Int ) : TT_F26Dot6; far;
433 begin
434 Read_CVT_Stretched := MulDiv_Round( exc.cvt^[index],
435 Get_Current_Ratio,
436 $10000 );
437 end;
438
439
440 procedure Write_CVT( index : Int; value : TT_F26Dot6 ); far;
441 begin
442 exc.cvt^[index] := value;
443 end;
444
445 procedure Write_CVT_Stretched( index : Int; value : TT_F26Dot6 ); far;
446 begin
447 exc.cvt^[index] := MulDiv_Round( value,
448 $10000,
449 Get_Current_Ratio );
450 end;
451
452
453 procedure Move_CVT( index : Int; value : TT_F26Dot6 ); far;
454 begin
455 inc( exc.cvt^[index], value );
456 end;
457
458 procedure Move_CVT_Stretched( index : Int; value : TT_F26dot6 ); far;
459 begin
460 inc( exc.cvt^[index], MulDiv_Round( value,
461 $10000,
462 Get_Current_Ratio ));
463 end;
464
465 (*******************************************************************
466 *
467 * Function : Calc_Length
468 *
469 * Description : Computes the length in bytes of current opcode
470 *
471 *****************************************************************)
472
473 function Calc_Length : boolean;
474 begin
475 Calc_Length := false;
476
477 exc.opcode := exc.Code^[exc.IP];
478
479 case exc.opcode of
480
481 $40 : if exc.IP+1 >= exc.codeSize
482 then exit
483 else
484 exc.length := exc.code^[exc.IP+1] + 2;
485
486 $41 : if exc.IP+1 >= exc.codeSize
487 then exit
488 else
489 exc.length := exc.code^[exc.IP+1]*2 + 2;
490
491 $B0..$B7 : exc.length := exc.opcode-$B0 + 2;
492 $B8..$BF : exc.length := (exc.opcode-$B8)*2 + 3;
493 else
494 exc.length := 1;
495 end;
496
497 Calc_Length := exc.IP+exc.length <= exc.codeSize;
498 end;
499
500 (*******************************************************************
501 *
502 * Function : Get_Short
503 *
504 * Description : Return a short integer taken from the instruction
505 * stream at address IP.
506 *
507 * Input : None
508 *
509 * Output : Short read at Code^[IP..IP+1]
510 *
511 * Notes : This one could become a Macro in the C version
512 *
513 *****************************************************************)
514
515 function GetShort : Short;
516 var
517 L : Array[0..1] of Byte;
518 resultat : Short absolute L; (* XXX : un-portable *)
519 begin
520 (* This is little-endian code *)
521
522 L[1] := exc.code^[exc.IP]; inc(exc.IP);
523 L[0] := exc.code^[exc.IP]; inc(exc.IP);
524 GetShort := resultat;
525 end;
526
527
528 function Goto_CodeRange( aRange,
529 aIP : Int ): boolean;
530 begin
531
532 Goto_CodeRange := False;
533
534 with exc do
535 begin
536 if (aRange<1) or (aRange>3) then
537 begin
538 exc.error := TT_Err_Bad_Argument;
539 exit;
540 end;
541
542 with CodeRangeTable[ARange] do
543 begin
544
545 if Base = nil then (* invalid coderange *)
546 begin
547 error := TT_Err_Invalid_Coderange;
548 exit;
549 end;
550
551 (* NOTE : Because the last instruction of a program may be a CALL *)
552 (* which will return to the first byte *after* the code *)
553 (* range, we test for AIP <= Size, instead of AIP < Size *)
554
555 if AIP > Size then
556 begin
557 error := TT_Err_Code_Overflow;
558 Goto_CodeRange := False;
559 exit;
560 end;
561
562 Code := PByte(Base);
563 CodeSize := Size;
564 IP := AIP;
565 end;
566
567 curRange := ARange;
568 end;
569
570 Goto_CodeRange := True;
571 end;
572
573
574 (*******************************************************************
575 *
576 * Function : Direct_Move
577 *
578 * Description : Moves a point by a given distance along the
579 * freedom vector.
580 *
581 * Input : Vx, Vy point coordinates to move
582 * touch touch flag to modify
583 * distance
584 *
585 * Output : None
586 *
587 *****************************************************************)
588
589 {$F+}
590 procedure Direct_Move( zone : PGlyph_Zone;
591 point : Int;
592 distance : TT_F26dot6 );
593 var
594 v : TT_F26dot6;
595 begin
596 v := exc.GS.freeVector.x;
597 if v <> 0 then
598 begin
599 inc( zone^.cur^[point].x, MulDiv_Round( distance,
600 Long(v)*$10000,
601 exc.F_dot_P ));
602
603 zone^.flags^[point] := zone^.flags^[point] or TT_Flag_Touched_X;
604 end;
605
606 v := exc.GS.freeVector.y;
607 if v <> 0 then
608 begin
609 inc( zone^.cur^[point].y, MulDiv_Round( distance,
610 Long(v)*$10000,
611 exc.F_dot_P ));
612
613 zone^.flags^[point] := zone^.flags^[point] or TT_Flag_Touched_Y;
614 end;
615 end;
616
617 (* The following versions are used whenever both vectors are both *)
618 (* along one of the coordinate unit vectors, i.e. in 90% cases *)
619
620 procedure Direct_Move_X( zone : PGlyph_Zone;
621 point : Int;
622 distance : TT_F26dot6 );
623 begin
624 inc( zone^.cur^[point].x, distance );
625 zone^.flags^[point] := zone^.flags^[point] or TT_Flag_Touched_X;
626 end;
627
628 procedure Direct_Move_Y( zone : PGlyph_Zone;
629 point : Int;
630 distance : TT_F26dot6 );
631 begin
632 inc( zone^.cur^[point].y, distance );
633 zone^.flags^[point] := zone^.flags^[point] or TT_Flag_Touched_Y;
634 end;
635
636 (*******************************************************************
637 *
638 * Function : Round_None
639 *
640 * Description : Do not round, but add engine compensation
641 *
642 * Input : distance : distance to round
643 * compensation : engine compensation
644 *
645 * Output : rounded distance
646 *
647 * NOTE : The spec says very few about the relationship between
648 * rounding and engine compensation. However, it seems
649 * from the description of super round that we should
650 * should add the compensation before rounding
651 *
652 *****************************************************************)
653
654 function Round_None( distance : TT_F26dot6;
655 compensation : TT_F26dot6 ) : TT_F26dot6;
656 var
657 val : TT_F26dot6;
658 begin
659 if distance >= 0 then
660 begin
661 val := distance + compensation;
662 if val < 0 then val := 0;
663 end
664 else
665 begin
666 val := distance - compensation;
667 if val > 0 then val := 0;
668 end;
669
670 Round_None := val;
671 end;
672
673 (*******************************************************************
674 *
675 * Function : Round_To_Grid
676 *
677 * Description : round value to grid after adding engine
678 * compensation
679 *
680 * Input : distance : distance to round
681 * compensation : engine compensation
682 *
683 * Output : rounded distance
684 *
685 *****************************************************************)
686
687 function Round_To_Grid( distance : TT_F26dot6;
688 compensation : TT_F26dot6 ) : TT_F26dot6;
689 var
690 val : TT_F26dot6;
691 begin
692 if distance >= 0 then
693 begin
694 val := (distance + 32 + compensation) and -64;
695 if val < 0 then val := 0;
696 end
697 else
698 begin
699 val := - ((compensation - distance + 32) and -64);
700 if val > 0 then val := 0;
701 end;
702
703 Round_To_Grid := val;
704 end;
705
706 (*******************************************************************
707 *
708 * Function : Round_To_Half_Grid
709 *
710 * Description : round value to half grid after adding engine
711 * compensation
712 *
713 * Input : distance : distance to round
714 * compensation : engine compensation
715 *
716 * Output : rounded distance
717 *
718 *****************************************************************)
719
720 function Round_To_Half_Grid( distance : TT_F26dot6;
721 compensation : TT_F26dot6 ) : TT_F26dot6;
722 var
723 val : TT_F26dot6;
724 begin
725 if distance >= 0 then
726 begin
727 val := (distance + compensation) and -64 + 32;
728 if val < 0 then val := 0;
729 end
730 else
731 begin
732 val := - ((-distance + compensation) and -64 + 32);
733 if val > 0 then val := 0;
734 end;
735
736 Round_To_Half_Grid := val;
737 end;
738
739
740 (*******************************************************************
741 *
742 * Function : Round_Down_To_Grid
743 *
744 * Description : round value down to grid after adding engine
745 * compensation
746 *
747 * Input : distance : distance to round
748 * compensation : engine compensation
749 *
750 * Output : rounded distance
751 *
752 *****************************************************************)
753
754 function Round_Down_To_Grid( distance : TT_F26dot6;
755 compensation : TT_F26dot6 ) : TT_F26dot6;
756 var
757 val : TT_F26dot6;
758 begin
759 if distance >= 0 then
760 begin
761 val := (distance + compensation) and -64;
762 if val < 0 then val := 0;
763 end
764 else
765 begin
766 val := - ((-distance + compensation) and -64);
767 if val > 0 then val := 0;
768 end;
769
770 Round_Down_To_Grid := val;
771 end;
772
773 (*******************************************************************
774 *
775 * Function : Round_Up_To_Grid
776 *
777 * Description : round value up to grid after adding engine
778 * compensation
779 *
780 * Input : distance : distance to round
781 * compensation : engine compensation
782 *
783 * Output : rounded distance
784 *
785 *****************************************************************)
786
787 function Round_Up_To_Grid( distance : TT_F26dot6;
788 compensation : TT_F26dot6 ) : TT_F26dot6;
789 var
790 val : TT_F26dot6;
791 begin
792 if distance >= 0 then
793 begin
794 val := (distance + 63 + compensation) and -64;
795 if val < 0 then val := 0;
796 end
797 else
798 begin
799 val := - ((-distance + 63 + compensation) and -64);
800 if val > 0 then val := 0;
801 end;
802
803 Round_Up_To_Grid := val;
804 end;
805
806 (*******************************************************************
807 *
808 * Function : Round_To_Double_Grid
809 *
810 * Description : round value to double grid after adding engine
811 * compensation
812 *
813 * Input : distance : distance to round
814 * compensation : engine compensation
815 *
816 * Output : rounded distance
817 *
818 *****************************************************************)
819
820 function Round_To_Double_Grid( distance : TT_F26dot6;
821 compensation : TT_F26dot6 ) : TT_F26dot6;
822 var
823 val : TT_F26dot6;
824 begin
825 if distance >= 0 then
826 begin
827 val := (distance + 16 + compensation) and -32;
828 if val < 0 then val := 0;
829 end
830 else
831 begin
832 val := - ((-distance + 16 + compensation) and -32);
833 if val > 0 then val := 0;
834 end;
835
836 Round_To_Double_Grid := val;
837 end;
838
839 (*******************************************************************
840 *
841 * Function : Round_Super
842 *
843 * Description : super round value to grid after adding engine
844 * compensation
845 *
846 * Input : distance : distance to round
847 * compensation : engine compensation
848 *
849 * Output : rounded distance
850 *
851 * NOTE : The spec says very few about the relationship between
852 * rounding and engine compensation. However, it seems
853 * from the description of super round that we should
854 * should add the compensation before rounding
855 *
856 *****************************************************************)
857
858 function Round_Super( distance : TT_F26dot6;
859 compensation : TT_F26dot6 ) : TT_F26dot6;
860 var
861 val : TT_F26dot6;
862 begin
863 with exc do
864
865 if distance >= 0 then
866 begin
867 val := (distance - phase + threshold + compensation) and -period;
868 if val < 0 then val := 0;
869 val := val + phase;
870 end
871 else
872 begin
873 val := -((-distance - phase + threshold + compensation) and -period);
874 if val > 0 then val := 0;
875 val := val - phase;
876 end;
877
878 Round_Super := val;
879 end;
880
881 (*******************************************************************
882 *
883 * Function : Round_Super_45
884 *
885 * Description : super round value to grid after adding engine
886 * compensation
887 *
888 * Input : distance : distance to round
889 * compensation : engine compensation
890 *
891 * Output : rounded distance
892 *
893 * NOTE : There is a separate function for Round_Super_45 as we
894 * may need a greater precision.
895 *
896 *****************************************************************)
897
898 function Round_Super_45( distance : TT_F26dot6;
899 compensation : TT_F26dot6 ) : TT_F26dot6;
900 var
901 val : TT_F26dot6;
902 begin
903 with exc do
904
905 if distance >= 0 then
906 begin
907 val := ((distance - phase + threshold + compensation) div period)
908 * period;
909 if val < 0 then val := 0;
910 val := val + phase;
911 end
912 else
913 begin
914 val := -((-distance - phase + threshold + compensation) div period
915 * period );
916 if val > 0 then val := 0;
917 val := val - phase;
918 end;
919
920 Round_Super_45 := val;
921 end;
922 {$F-}
923
924 procedure Compute_Round( round_mode : Byte );
925 begin
926 case Round_Mode of
927
928 {$IFDEF FPK}
929 TT_Round_Off : exc.func_round := @Round_None;
930 TT_Round_To_Grid : exc.func_round := @Round_To_Grid;
931 TT_Round_Up_To_Grid : exc.func_round := @Round_Up_To_Grid;
932 TT_Round_Down_To_Grid : exc.func_round := @Round_Down_To_Grid;
933 TT_Round_To_Half_Grid : exc.func_round := @Round_To_Half_Grid;
934 TT_Round_To_Double_Grid : exc.func_round := @Round_To_Double_Grid;
935 TT_Round_Super : exc.func_round := @Round_Super;
936 TT_Round_Super_45 : exc.func_round := @Round_Super_45;
937 {$ELSE}
938 TT_Round_Off : exc.func_round := Round_None;
939 TT_Round_To_Grid : exc.func_round := Round_To_Grid;
940 TT_Round_Up_To_Grid : exc.func_round := Round_Up_To_Grid;
941 TT_Round_Down_To_Grid : exc.func_round := Round_Down_To_Grid;
942 TT_Round_To_Half_Grid : exc.func_round := Round_To_Half_Grid;
943 TT_Round_To_Double_Grid : exc.func_round := Round_To_Double_Grid;
944 TT_Round_Super : exc.func_round := Round_Super;
945 TT_Round_Super_45 : exc.func_round := Round_Super_45;
946 {$ENDIF}
947 end;
948 end;
949
950
951 (*******************************************************************
952 *
953 * Function : SetSuperRound
954 *
955 * Description : Set Super Round parameters
956 *
957 * Input : GridPeriod Grid period
958 * OpCode SROUND opcode
959 *
960 * Output : None
961 *
962 * Notes :
963 *
964 *****************************************************************)
965
966 procedure SetSuperRound( GridPeriod : TT_F26dot6; selector : Long );
967
968 begin
969 with exc do
970 begin
971
972 Case selector and $C0 of
973
974 $00 : period := GridPeriod div 2;
975 $40 : period := GridPeriod;
976 $80 : period := GridPeriod * 2;
977
978 (* This opcode is reserved, but ... *)
979
980 $C0 : period := GridPeriod;
981 end;
982
983 Case selector and $30 of
984
985 $00 : phase := 0;
986 $10 : phase := period div 4;
987 $20 : phase := period div 2;
988 $30 : phase := gridPeriod*3 div 4;
989 end;
990
991 if selector and $F = 0 then
992
993 Threshold := Period-1
994 else
995 Threshold := (Integer( selector and $F )-4)*period div 8;
996
997 period := period div 256;
998 phase := phase div 256;
999 threshold := threshold div 256;
1000
1001 end
1002 end;
1003
1004 (*******************************************************************
1005 *
1006 * Function : Project
1007 *
1008 * Description : Computes the projection of (Vx,Vy) along the
1009 * current projection vector
1010 *
1011 * Input : Vx, Vy input vector
1012 *
1013 * Output : return distance in F26dot6
1014 *
1015 *****************************************************************)
1016
1017 {$F+}
1018 function Project( var P1, P2 : TT_Vector ) : TT_F26dot6;
1019 var
1020 T1, T2 : Int64;
1021 begin
1022 with exc.GS.projVector do
1023 begin
1024 MulTo64( P1.x - P2.x, x, T1 );
1025 MulTo64( P1.y - P2.y, y, T2 );
1026 end;
1027
1028 Add64( T1, T2, T1 );
1029
1030 Project := Div64by32( T1, $4000 );
1031 end;
1032
1033
1034 function Dual_Project( var P1, P2 : TT_Vector ) : TT_F26dot6;
1035 var
1036 T1, T2 : Int64;
1037 begin
1038 with exc.GS.dualVector do
1039 begin
1040 MulTo64( P1.x - P2.x, x, T1 );
1041 MulTo64( P1.y - P2.y, y, T2 );
1042 end;
1043
1044 Add64( T1, T2, T1 );
1045
1046 Dual_Project := Div64by32( T1, $4000 );
1047 end;
1048
1049
1050 function Free_Project( var P1, P2 : TT_Vector ) : TT_F26dot6;
1051 var
1052 T1, T2 : Int64;
1053 begin
1054 with exc.GS.freeVector do
1055 begin
1056 MulTo64( P1.x - P2.x, x, T1 );
1057 MulTo64( P1.y - P2.y, y, T2 );
1058 end;
1059
1060 Add64( T1, T2, T1 );
1061
1062 Free_Project := Div64by32( T1, $4000 );
1063 end;
1064
1065
1066 function Project_x( var P1, P2 : TT_Vector ) : TT_F26dot6;
1067 begin
1068 Project_x := P1.x - P2.x;
1069 end;
1070
1071 function Project_y( var P1, P2 : TT_Vector ) : TT_F26dot6;
1072 begin
1073 Project_y := P1.y - P2.y;
1074 end;
1075 {$F-}
1076
1077 (*******************************************************************
1078 *
1079 * Function : Compute_Funcs
1080 *
1081 * Description : Computes the projections and movement function
1082 * pointers according to the current graphics state
1083 *
1084 * Input : None
1085 *
1086 *****************************************************************)
1087
1088 procedure Compute_Funcs;
1089 begin
1090 with exc, GS do
1091 begin
1092
1093 if (freeVector.x = $4000) then
1094 begin
1095 {$IFDEF FPK}
1096 func_freeProj := @Project_x;
1097 {$ELSE}
1098 func_freeProj := Project_x;
1099 {$ENDIF}
1100 F_dot_P := Long(projVector.x) * $10000;
1101 end
1102 else
1103 if (freeVector.y = $4000) then
1104 begin
1105 {$IFDEF FPK}
1106 func_freeProj := @Project_y;
1107 {$ELSE}
1108 func_freeProj := Project_y;
1109 {$ENDIF}
1110 F_dot_P := Long(projVector.y) * $10000;
1111 end
1112 else
1113 begin
1114 {$IFDEF FPK}
1115 func_move := @Direct_Move;
1116 func_freeProj := @Free_Project;
1117 {$ELSE}
1118 func_move := Direct_Move;
1119 func_freeProj := Free_Project;
1120 {$ENDIF}
1121 F_dot_P := Long(projVector.x) * freeVector.x * 4 +
1122 Long(projVector.y) * freeVector.y * 4;
1123 end;
1124
1125 {$IFDEF FPK}
1126 if (projVector.x = $4000) then func_Project := @Project_x
1127 else
1128 if (projVector.y = $4000) then func_Project := @Project_y
1129 else
1130 func_Project := @Project;
1131
1132 if (dualVector.x = $4000) then func_dualproj := @Project_x
1133 else
1134 if (dualVector.y = $4000) then func_dualproj := @Project_y
1135 else
1136 func_dualproj := @Dual_Project;
1137
1138 func_move := @Direct_Move;
1139
1140 if F_dot_P = $40000000 then
1141
1142 if freeVector.x = $4000 then func_move := @Direct_Move_x
1143 else
1144 if freeVector.y = $4000 then func_move := @Direct_Move_y;
1145 {$ELSE}
1146 if (projVector.x = $4000) then func_Project := Project_x
1147 else
1148 if (projVector.y = $4000) then func_Project := Project_y
1149 else
1150 func_Project := Project;
1151
1152 if (dualVector.x = $4000) then func_dualproj := Project_x
1153 else
1154 if (dualVector.y = $4000) then func_dualproj := Project_y
1155 else
1156 func_dualproj := Dual_Project;
1157
1158 func_move := Direct_Move;
1159
1160 if F_dot_P = $40000000 then
1161
1162 if freeVector.x = $4000 then func_move := Direct_Move_x
1163 else
1164 if freeVector.y = $4000 then func_move := Direct_Move_y;
1165 {$ENDIF}
1166
1167 (* at small sizes, F_dot_P can become too small, resulting *)
1168 (* in overflows and 'spikes' in a number of glyfs like 'w' *)
1169
1170 if abs( F_dot_P ) < $4000000 then F_dot_P := $40000000;
1171
1172 (* set aspect ratio to 0 to force recomputation by Get_Current_Ratio *)
1173 metrics.ratio := 0;
1174 end;
1175 end;
1176
1177
1178 (**************************************************)
1179 (* *)
1180 (* Normalize : Normer un vecteur ( U, V ) *)
1181 (* r‚sultat dans ( X, Y ) *)
1182 (* False si vecteur paramŠtre nul *)
1183 (* *)
1184 (**************************************************)
1185
1186 function Normalize( U, V : TT_F26dot6; var R : TT_UnitVector ): boolean;
1187 var
1188 Vec : TT_Vector;
1189 W : TT_F26dot6;
1190 S1, S2 : Boolean;
1191 T : Int64;
1192 begin
1193
1194 if (Abs(U) < $10000) and (Abs(V) < $10000) then
1195 begin
1196 U := U*$100;
1197 V := V*$100;
1198
1199 W := Norm( U, V );
1200 if W = 0 then
1201 begin
1202 (* XXX : Undocumented. Apparently, it is possible to try *)
1203 (* to normalize the vector (0,0). Return success *)
1204 (* in this case *)
1205 Normalize := SUCCESS;
1206 exit;
1207 end;
1208
1209 R.x := MulDiv( U, $4000, W );
1210 R.y := MulDiv( V, $4000, W );
1211
1212 end
1213 else
1214 begin
1215
1216 W := Norm( U, V );
1217
1218 if W > 0 then
1219 begin
1220 U := MulDiv( U, $4000, W );
1221 V := MulDiv( V, $4000, W );
1222
1223 W := U*U + V*V;
1224
1225 (* Now, we want that Sqrt( W ) = $4000 *)
1226 (* Or $1000000 <= W < $1004000 *)
1227
1228 if U < 0 then begin U := -U; S1 := True; end else S1 := False;
1229 if V < 0 then begin V := -V; S2 := True; end else S2 := False;
1230
1231 while W < $1000000 do
1232 begin
1233 (* We need to increase W, by a minimal amount *)
1234 if U < V then inc( U )
1235 else inc( V );
1236 W := U*U + V*V;
1237 end;
1238
1239 while W >= $1004000 do
1240 begin
1241 (* We need to decrease W, by a minimal amount *)
1242 if U < V then dec( U )
1243 else dec( V );
1244 W := U*U + V*V;
1245 end;
1246
1247 (* Note that in various cases, we can only *)
1248 (* compute a Sqrt(W) of $3FFF, eg. U=V *)
1249
1250 if S1 then U := -U;
1251 if S2 then V := -V;
1252
1253 R.x := U; (* Type conversion *)
1254 R.y := V; (* Type conversion *)
1255
1256 end
1257 else
1258 begin
1259 Normalize := False;
1260 exc.error := TT_Err_Divide_By_Zero;
1261 end;
1262 end;
1263
1264 Normalize := True;
1265 end;
1266
1267 {$F+}
1268
1269 (****************************************************************)
1270 (* *)
1271 (* MANAGING THE STACK *)
1272 (* *)
1273 (* Instructions appear in the specs' order *)
1274 (* *)
1275 (****************************************************************)
1276
1277 (*******************************************)
1278 (* DUP[] : Duplicate top stack element *)
1279 (* CodeRange : $20 *)
1280
1281 procedure Ins_DUP( args : PStorage );
1282 begin
1283 args^[1] := args^[0];
1284 end;
1285
1286 (*******************************************)
1287 (* POP[] : POPs the stack's top elt. *)
1288 (* CodeRange : $21 *)
1289
1290 procedure Ins_POP( args : PStorage );
1291 begin
1292 (* nothing to do *)
1293 end;
1294
1295 (*******************************************)
1296 (* CLEAR[] : Clear the entire stack *)
1297 (* CodeRange : $22 *)
1298
1299 procedure Ins_CLEAR( args : PStorage );
1300 begin
1301 exc.new_top := 0;
1302 end;
1303
1304 (*******************************************)
1305 (* SWAP[] : Swap the top two elements *)
1306 (* CodeRange : $23 *)
1307
1308 procedure Ins_SWAP( args : PStorage );
1309 var L : Long;
1310 begin
1311 L := args^[0];
1312 args^[0] := args^[1];
1313 args^[1] := L;
1314 end;
1315
1316 (*******************************************)
1317 (* DEPTH[] : return the stack depth *)
1318 (* CodeRange : $24 *)
1319
1320 procedure Ins_DEPTH( args : PStorage );
1321 begin
1322 args^[0] := exc.top;
1323 end;
1324
1325 (*******************************************)
1326 (* CINDEX[] : copy indexed element *)
1327 (* CodeRange : $25 *)
1328
1329 procedure Ins_CINDEX( args : PStorage );
1330 var
1331 L : Long;
1332 begin
1333 L := args^[0];
1334 if (L <= 0) or (L > exc.args) then
1335 exc.error := TT_Err_Invalid_Reference
1336 else
1337 args^[0] := exc.stack^[exc.args-l];
1338 end;
1339
1340 (*******************************************)
1341 (* MINDEX[] : move indexed element *)
1342 (* CodeRange : $26 *)
1343
1344 procedure Ins_MINDEX( args : PStorage );
1345 var
1346 L, K : Long;
1347 begin
1348 L := args^[0];
1349 if (L <= 0) or (L > exc.args) then
1350 exc.Error := TT_Err_Invalid_Reference
1351 else
1352 begin
1353 K := exc.stack^[exc.args-L];
1354
1355 move( exc.stack^[exc.args-L+1],
1356 exc.stack^[exc.args-L],
1357 (L-1)*sizeof(Long) );
1358
1359 exc.stack^[exc.args-1] := K;
1360 end;
1361 end;
1362
1363 (*******************************************)
1364 (* ROLL[] : roll top three elements *)
1365 (* CodeRange : $8A *)
1366
1367 procedure Ins_ROLL( args : PStorage );
1368 var
1369 A, B, C : Long;
1370 begin
1371 A := args^[2];
1372 B := args^[1];
1373 C := args^[0];
1374
1375 args^[2] := C;
1376 args^[1] := A;
1377 args^[0] := B;
1378 end;
1379
1380 (****************************************************************)
1381 (* *)
1382 (* MANAGING THE FLOW OF CONTROL *)
1383 (* *)
1384 (* Instructions appear in the specs' order *)
1385 (* *)
1386 (****************************************************************)
1387
1388 function SkipCode : boolean;
1389 var
1390 b : Boolean;
1391 begin
1392 b := False;
1393
1394 inc( exc.IP, exc.length );
1395
1396 b := exc.IP < exc.codeSize;
1397
1398 if b then b := Calc_Length;
1399
1400 if not b then
1401 exc.error := TT_Err_Code_Overflow;
1402
1403 SkipCode := b;
1404 end;
1405
1406
1407 (*******************************************)
1408 (* IF[] : IF test *)
1409 (* CodeRange : $58 *)
1410
1411 procedure Ins_IF( args : PStorage );
1412 var
1413 nIfs : Int;
1414 Out : Boolean;
1415 begin
1416 if args^[0] <> 0 then exit;
1417
1418 nIfs := 1;
1419 Out := False;
1420
1421 Repeat
1422
1423 if not SkipCode then exit;
1424
1425 Case exc.opcode of
1426
1427 (* IF *)
1428 $58 : inc( nIfs );
1429
1430 (* ELSE *)
1431 $1B : out:= nIfs=1;
1432
1433 (* EIF *)
1434 $59 : begin
1435 dec( nIfs );
1436 out:= nIfs=0;
1437 end;
1438 end;
1439
1440 until Out;
1441 end;
1442
1443
1444 (*******************************************)
1445 (* ELSE[] : ELSE *)
1446 (* CodeRange : $1B *)
1447
1448 procedure Ins_ELSE( args : PStorage );
1449 var
1450 nIfs : Int;
1451 begin
1452 nIfs := 1;
1453
1454 Repeat
1455
1456 if not SkipCode then exit;
1457
1458 case exc.opcode of
1459
1460 (* IF *)
1461 $58 : inc( nIfs );
1462
1463 (* EIF *)
1464 $59 : dec( nIfs );
1465 end;
1466
1467 until nIfs=0;
1468 end;
1469
1470 (*******************************************)
1471 (* EIF[] : End IF *)
1472 (* CodeRange : $59 *)
1473
1474 procedure Ins_EIF( args : PStorage );
1475 begin
1476 (* nothing to do *)
1477 end;
1478
1479 (*******************************************)
1480 (* JROT[] : Jump Relative On True *)
1481 (* CodeRange : $78 *)
1482
1483 procedure Ins_JROT( args : PStorage );
1484 begin
1485 if args^[1] <> 0 then
1486 begin
1487 inc( exc.IP, args^[0] );
1488 exc.step_ins := false;
1489 end;
1490 end;
1491
1492 (*******************************************)
1493 (* JMPR[] : JuMP Relative *)
1494 (* CodeRange : $1C *)
1495
1496 procedure Ins_JMPR( args : PStorage );
1497 begin
1498 inc( exc.IP, args^[0] );
1499 exc.step_ins := false;
1500 end;
1501
1502 (*******************************************)
1503 (* JROF[] : Jump Relative On False *)
1504 (* CodeRange : $79 *)
1505
1506 procedure Ins_JROF( args : PStorage );
1507 begin
1508 if args^[1] = 0 then
1509 begin
1510 inc( exc.IP, args^[0] );
1511 exc.step_ins := false;
1512 end;
1513 end;
1514
1515 (****************************************************************)
1516 (* *)
1517 (* LOGICAL FUNCTIONS *)
1518 (* *)
1519 (* Instructions appear in the specs' order *)
1520 (* *)
1521 (****************************************************************)
1522
1523 (*******************************************)
1524 (* LT[] : Less Than *)
1525 (* CodeRange : $50 *)
1526
1527 procedure Ins_LT( args : PStorage );
1528 begin
1529 if args^[0] < args^[1] then args^[0] := 1
1530 else args^[0] := 0;
1531 end;
1532
1533 (*******************************************)
1534 (* LTEQ[] : Less Than or EQual *)
1535 (* CodeRange : $51 *)
1536
1537 procedure Ins_LTEQ( args : PStorage );
1538 begin
1539 if args^[0] <= args^[1] then args^[0] := 1
1540 else args^[0] := 0;
1541 end;
1542
1543 (*******************************************)
1544 (* GT[] : Greater Than *)
1545 (* CodeRange : $52 *)
1546
1547 procedure Ins_GT( args : PStorage );
1548 begin
1549 if args^[0] > args^[1] then args^[0] := 1
1550 else args^[0] := 0;
1551 end;
1552
1553 (*******************************************)
1554 (* GTEQ[] : Greater Than or EQual *)
1555 (* CodeRange : $53 *)
1556
1557 procedure Ins_GTEQ( args : PStorage );
1558 begin
1559 if args^[0] >= args^[1] then args^[0] := 1
1560 else args^[0] := 0;
1561 end;
1562
1563 (*******************************************)
1564 (* EQ[] : EQual *)
1565 (* CodeRange : $54 *)
1566
1567 procedure Ins_EQ( args : PStorage );
1568 begin
1569 if args^[0] = args^[1] then args^[0] := 1
1570 else args^[0] := 0;
1571 end;
1572
1573 (*******************************************)
1574 (* NEQ[] : Not EQual *)
1575 (* CodeRange : $55 *)
1576
1577 procedure Ins_NEQ( args : PStorage );
1578 begin
1579 if args^[0] <> args^[1] then args^[0] := 1
1580 else args^[0] := 0;
1581 end;
1582
1583 (*******************************************)
1584 (* ODD[] : Odd *)
1585 (* CodeRange : $56 *)
1586
1587 procedure Ins_ODD( args : PStorage );
1588 begin
1589 if exc.func_round( args^[0], 0 ) and 127 = 64 then args^[0] := 1
1590 else args^[0] := 0;
1591 end;
1592
1593 (*******************************************)
1594 (* EVEN[] : Even *)
1595 (* CodeRange : $57 *)
1596
1597 procedure Ins_EVEN( args : PStorage );
1598 begin
1599 if exc.func_round( args^[0], 0 ) and 127 = 0 then args^[0] := 1
1600 else args^[0] := 0;
1601 end;
1602
1603 (*******************************************)
1604 (* AND[] : logical AND *)
1605 (* CodeRange : $5A *)
1606
1607 procedure Ins_AND( args : PStorage );
1608 begin
1609 if ( args^[0] <> 0 ) and
1610 ( args^[1] <> 0 ) then args^[0] := 1
1611 else args^[0] := 0;
1612 end;
1613
1614 (*******************************************)
1615 (* OR[] : logical OR *)
1616 (* CodeRange : $5B *)
1617
1618 procedure Ins_OR( args : PStorage );
1619 begin
1620 if ( args^[0] <> 0 ) or
1621 ( args^[1] <> 0 ) then args^[0] := 1
1622 else args^[0] := 0;
1623 end;
1624
1625 (*******************************************)
1626 (* NOT[] : logical NOT *)
1627 (* CodeRange : $5C *)
1628
1629 procedure Ins_NOT( args : PStorage );
1630 begin
1631 if args^[0] <> 0 then args^[0] := 0
1632 else args^[0] := 1;
1633 end;
1634
1635 (****************************************************************)
1636 (* *)
1637 (* ARITHMETIC AND MATH INSTRUCTIONS *)
1638 (* *)
1639 (* Instructions appear in the specs' order *)
1640 (* *)
1641 (****************************************************************)
1642
1643 (*******************************************)
1644 (* ADD[] : ADD *)
1645 (* CodeRange : $60 *)
1646
1647 procedure Ins_ADD( args : PStorage );
1648 begin
1649 inc( args^[0], args^[1] );
1650 end;
1651
1652 (*******************************************)
1653 (* SUB[] : SUBstract *)
1654 (* CodeRange : $61 *)
1655
1656 procedure Ins_SUB( args : PStorage );
1657 begin
1658 dec( args^[0], args^[1] );
1659 end;
1660
1661 (*******************************************)
1662 (* DIV[] : DIVide *)
1663 (* CodeRange : $62 *)
1664
1665 procedure Ins_DIV( args : PStorage );
1666 begin
1667 if args^[1] = 0 then
1668 begin
1669 exc.error := TT_Err_Divide_By_Zero;
1670 exit;
1671 end;
1672
1673 args^[0] := MulDiv_Round( args^[0], 64, args^[1] );
1674 end;
1675
1676 (*******************************************)
1677 (* MUL[] : MULtiply *)
1678 (* CodeRange : $63 *)
1679
1680 procedure Ins_MUL( args : PStorage );
1681 begin
1682 args^[0] := MulDiv_Round( args^[0], args^[1], 64 );
1683 end;
1684
1685 (*******************************************)
1686 (* ABS[] : ABSolute value *)
1687 (* CodeRange : $64 *)
1688
1689 procedure Ins_ABS( args : PStorage );
1690 begin
1691 args^[0] := abs( args^[0] );
1692 end;
1693
1694 (*******************************************)
1695 (* NEG[] : NEGate *)
1696 (* CodeRange : $65 *)
1697
1698 procedure Ins_NEG( args : PStorage );
1699 begin
1700 args^[0] := -args^[0];
1701 end;
1702
1703 (*******************************************)
1704 (* FLOOR[] : FLOOR *)
1705 (* CodeRange : $66 *)
1706
1707 procedure Ins_FLOOR( args : PStorage );
1708 begin
1709 args^[0] := args^[0] and -64;
1710 end;
1711
1712 (*******************************************)
1713 (* CEILING[] : CEILING *)
1714 (* CodeRange : $67 *)
1715
1716 procedure Ins_CEILING( args : PStorage );
1717 begin
1718 args^[0] := ( args^[0]+63 ) and -64;
1719 end;
1720
1721 (*******************************************)
1722 (* MAX[] : MAXimum *)
1723 (* CodeRange : $68 *)
1724
1725 procedure Ins_MAX( args : PStorage );
1726 begin
1727 if args^[1] > args^[0] then args^[0] := args^[1];
1728 end;
1729
1730 (*******************************************)
1731 (* MIN[] : MINimum *)
1732 (* CodeRange : $69 *)
1733
1734 procedure Ins_MIN( args : PStorage );
1735 begin
1736 if args^[1] < args^[0] then args^[0] := args^[1];
1737 end;
1738
1739 (****************************************************************)
1740 (* *)
1741 (* COMPENSATING FOR THE ENGINE CHARACTERISTICS *)
1742 (* *)
1743 (* Instructions appear in the specs' order *)
1744 (* *)
1745 (****************************************************************)
1746
1747 (*******************************************)
1748 (* ROUND[ab] : ROUND value *)
1749 (* CodeRange : $68-$6B *)
1750
1751 procedure Ins_ROUND( args : PStorage );
1752 begin
1753 args^[0] := exc.func_round( args^[0],
1754 exc.metrics.compensations[ exc.opcode-$68 ] );
1755 end;
1756
1757 (*******************************************)
1758 (* NROUND[ab]: No ROUNDing of value *)
1759 (* CodeRange : $6C-$6F *)
1760
1761 procedure Ins_NROUND( args : PStorage );
1762 begin
1763 args^[0] := Round_None( args^[0],
1764 exc.metrics.compensations[ exc.opcode-$6C ] );
1765 end;
1766
1767 (****************************************************************)
1768 (* *)
1769 (* DEFINING AND USING FUNCTIONS AND INSTRUCTIONS *)
1770 (* *)
1771 (* Instructions appear in the specs' order *)
1772 (* *)
1773 (****************************************************************)
1774
1775 (*******************************************)
1776 (* FDEF[] : Function DEFinition *)
1777 (* CodeRange : $2C *)
1778
1779 procedure Ins_FDEF( args : PStorage );
1780 var
1781 func : int;
1782 label
1783 Suite;
1784 begin
1785
1786 (* check space *)
1787 if exc.numFDefs >= exc.maxFDefs then begin
1788 exc.error := TT_Err_Too_Many_FuncDefs;
1789 exit;
1790 end;
1791
1792 func := Int(args^[0]);
1793 with exc.FDefs^[exc.numFDefs] do
1794 begin
1795 Range := exc.curRange;
1796 Opc := func;
1797 Start := exc.IP+1;
1798 Active := True;
1799 end;
1800
1801 if func > exc.maxFunc then
1802 exc.maxFunc := func;
1803
1804 inc(exc.numFDefs);
1805
1806 (* now skip the whole function definition *)
1807 (* we don't allow nested IDEFS & FDEFs *)
1808
1809 while SkipCode do
1810
1811 case exc.opcode of
1812
1813 $89, (* IDEF *)
1814 $2C : (* FDEF *)
1815 begin
1816 exc.error := TT_Err_Nested_Defs;
1817 exit;
1818 end;
1819
1820 $2D : (* ENDF *)
1821 exit;
1822 end;
1823 end;
1824
1825 (*******************************************)
1826 (* ENDF[] : END Function definition *)
1827 (* CodeRange : $2D *)
1828
1829 procedure Ins_ENDF( args : PStorage );
1830 begin
1831
1832 if exc.callTop <= 0 then (* We encountered an ENDF without a call *)
1833 begin
1834 exc.error := TT_Err_ENDF_in_Exec_Stream;
1835 exit;
1836 end;
1837
1838 dec( exc.CallTop );
1839
1840 with exc.Callstack^[exc.CallTop] do
1841 begin
1842 dec( Cur_Count );
1843
1844 exc.step_ins := false;
1845
1846 if Cur_Count > 0 then
1847
1848 begin
1849 (* Loop the current function *)
1850 inc( exc.callTop );
1851 exc.IP := Cur_Restart;
1852 end
1853
1854 else
1855 (* exit the current call frame *)
1856 (* NOTE : When the last intruction of a program *)
1857 (* is a CALL or LOOPCALL, the return address *)
1858 (* is always out of the code range. This is *)
1859 (* valid address, and is why we do not test *)
1860 (* the result of Goto_CodeRange here !! *)
1861
1862 Goto_CodeRange( Caller_Range, Caller_IP )
1863 end;
1864
1865 end;
1866
1867 (*******************************************)
1868 (* CALL[] : CALL function *)
1869 (* CodeRange : $2B *)
1870
1871 procedure Ins_CALL( args : PStorage );
1872 var
1873 ii, nn : Int;
1874 def : PDefRecord;
1875 label
1876 Fail;
1877 begin
1878
1879 (* First of all, check index *)
1880 if (args^[0] < 0) or (args^[0] > exc.maxFunc) then
1881 goto Fail;
1882
1883 (* Except for some old Apple fonts, all functions in a TrueType *)
1884 (* fonts are defined in increasing order, starting from 0. *)
1885 (* *)
1886 (* This mean that, normally, we have : *)
1887 (* *)
1888 (* exc.maxFunc+1 = exc.numFDefs *)
1889 (* exc.FDefs[n].opc = n for n in 0..exc.maxFunc *)
1890 (* *)
1891
1892 nn := Int(args^[0]);
1893 def := @exc.FDefs^[nn];
1894
1895 if ( exc.maxFunc+1 <> exc.numFDefs ) or ( def^.opc <> nn ) then begin
1896 (* lookup the FDefs table *)
1897 ii := 0;
1898 def := @exc.FDefs^[0];
1899 while (ii < exc.numFDefs) and (def^.opc <> nn) do begin
1900 inc(ii);
1901 inc(def);
1902 end;
1903
1904 (* Fail if the function isn't listed *)
1905 if ii >= exc.numFDefs then
1906 goto Fail;
1907 end;
1908
1909 (* check that the function is active *)
1910 if not def^.active then
1911 goto Fail;
1912
1913 (* check call stack *)
1914 if exc.callTop >= exc.callSize then
1915 begin
1916 exc.error := TT_Err_Stack_Overflow;
1917 exit;
1918 end;
1919
1920 with exc.callstack^[exc.callTop] do
1921 begin
1922 Caller_Range := exc.curRange;
1923 Caller_IP := exc.IP+1;
1924 Cur_Count := 1;
1925 Cur_Restart := def^.Start;
1926 end;
1927
1928 inc( exc.CallTop );
1929
1930 with def^ do Goto_CodeRange( Range, Start );
1931
1932 exc.step_ins := false;
1933 exit;
1934
1935 Fail:
1936 exc.error := TT_Err_Invalid_Reference;
1937 exit;
1938 end;
1939
1940 (*******************************************)
1941 (* LOOPCALL[]: LOOP and CALL function *)
1942 (* CodeRange : $2A *)
1943
1944 procedure Ins_LOOPCALL( args : PStorage );
1945 begin
1946
1947 if ( args^[1] < 0 ) or ( args^[1] >= exc.numFDefs ) or
1948 ( not exc.FDefs^[args^[1]].Active ) then
1949 begin
1950 exc.error := TT_Err_Invalid_Reference;
1951 exit;
1952 end;
1953
1954 if exc.callTop >= exc.callSize then
1955 begin
1956 exc.error := TT_Err_Stack_Overflow;
1957 exit;
1958 end;
1959
1960 if args^[0] > 0 then
1961 begin
1962 with exc.callstack^[exc.callTop] do
1963 begin
1964 Caller_Range := exc.curRange;
1965 Caller_IP := exc.IP+1;
1966 Cur_Count := args^[0];
1967 Cur_Restart := exc.FDefs^[args^[1]].Start;
1968 end;
1969
1970 inc( exc.CallTop );
1971
1972 with exc.FDefs^[args^[1]] do Goto_CodeRange( Range, Start );
1973
1974 exc.step_ins := false;
1975 end;
1976
1977 end;
1978
1979 (*******************************************)
1980 (* IDEF[] : Instruction DEFinition *)
1981 (* CodeRange : $89 *)
1982
1983 procedure Ins_IDEF( args : PStorage );
1984 var
1985 i, A : Int;
1986 begin
1987
1988 A := 0;
1989
1990 while ( A < exc.numIDefs ) do
1991 with exc.IDefs^[A] do
1992 begin
1993
1994 if not Active then
1995 begin
1996 Opc := args^[0];
1997 Start := exc.IP+1;
1998 Range := exc.curRange;
1999 Active := True;
2000
2001 A := exc.numIDefs;
2002
2003 (* now skip the whole function definition *)
2004 (* we don't allow nested IDEFS & FDEFs *)
2005
2006 while SkipCode do
2007 case exc.opcode of
2008
2009 $89, (* IDEF *)
2010 $2C : (* FDEF *)
2011 begin
2012 exc.error := TT_Err_Nested_Defs;
2013 exit;
2014 end;
2015
2016 $2D : (* ENDF *)
2017 exit;
2018 end;
2019 end
2020 else
2021 inc( A );
2022 end;
2023 end;
2024
2025 (****************************************************************)
2026 (* *)
2027 (* PUSHING DATA ONTO THE INTERPRETER STACK *)
2028 (* *)
2029 (* Instructions appear in the specs' order *)
2030 (* *)
2031 (****************************************************************)
2032
2033 (*******************************************)
2034 (* NPUSHB[] : PUSH N Bytes *)
2035 (* CodeRange : $40 *)
2036
2037 procedure Ins_NPUSHB( args : PStorage );
2038 var
2039 L, K : Long;
2040 begin
2041 L := exc.code^[exc.IP+1];
2042
2043 if exc.top + L > exc.stackSize then
2044 begin
2045 exc.error := TT_Err_Stack_Overflow;
2046 exit;
2047 end;
2048
2049 for K := 1 to L do
2050 args^[k-1] := exc.code^[exc.IP+1+k];
2051
2052 inc( exc.new_top, L );
2053 end;
2054
2055 (*******************************************)
2056 (* NPUSHW[] : PUSH N Words *)
2057 (* CodeRange : $41 *)
2058
2059 procedure Ins_NPUSHW( args : PStorage );
2060 var
2061 L, K : Long;
2062 begin
2063 L := exc.code^[exc.IP+1];
2064
2065 if exc.top + L > exc.stackSize then
2066 begin
2067 exc.error := TT_Err_Stack_Overflow;
2068 exit;
2069 end;
2070
2071 inc( exc.IP, 2 );
2072
2073 for K := 1 to L do
2074 args^[k-1] := GetShort;
2075
2076 exc.step_ins := false;
2077
2078 inc( exc.new_top, L );
2079 end;
2080
2081 (*******************************************)
2082 (* PUSHB[abc]: PUSH Bytes *)
2083 (* CodeRange : $B0-$B7 *)
2084
2085 procedure Ins_PUSHB( args : PStorage );
2086 var
2087 L, K : Long;
2088 begin
2089 L := exc.opcode - $B0+1;
2090
2091 if exc.top + L >= exc.stackSize then
2092 begin
2093 exc.error := TT_Err_Stack_Overflow;
2094 exit;
2095 end;
2096
2097 for k := 1 to L do
2098 args^[k-1] := exc.code^[exc.ip+k];
2099
2100 end;
2101
2102 (*******************************************)
2103 (* PUSHW[abc]: PUSH Words *)
2104 (* CodeRange : $B8-$BF *)
2105
2106 procedure Ins_PUSHW( args : PStorage );
2107 var
2108 L, K : Long;
2109 begin
2110 L := exc.opcode - $B8+1;
2111
2112 if exc.top + L >= exc.stackSize then
2113 begin
2114 exc.error := TT_Err_Stack_Overflow;
2115 exit;
2116 end;
2117
2118 inc( exc.IP );
2119
2120 for k := 1 to L do
2121 args^[k-1] := GetShort;
2122
2123 exc.step_ins := false;
2124
2125 end;
2126
2127 (****************************************************************)
2128 (* *)
2129 (* MANAGING THE STORAGE AREA *)
2130 (* *)
2131 (* Instructions appear in the specs' order *)
2132 (* *)
2133 (****************************************************************)
2134
2135 (*******************************************)
2136 (* RS[] : Read Store *)
2137 (* CodeRange : $43 *)
2138
2139 procedure Ins_RS( args : PStorage );
2140 begin
2141 if (args^[0] < 0) or (args^[0] >= exc.storeSize) then
2142 begin
2143 exc.error := TT_Err_Invalid_Reference;
2144 exit;
2145 end;
2146
2147 args^[0] := exc.storage^[args^[0]];
2148 end;
2149
2150 (*******************************************)
2151 (* WS[] : Write Store *)
2152 (* CodeRange : $42 *)
2153
2154 procedure Ins_WS( args : PStorage );
2155 begin
2156 if (args^[0] < 0) or (args^[0] >= exc.storeSize) then
2157 begin
2158 exc.error := TT_Err_Invalid_Reference;
2159 exit;
2160 end;
2161
2162 exc.storage^[args^[0]] := args^[1];
2163 end;
2164
2165 (*******************************************)
2166 (* WCVTP[] : Write CVT in Pixel units *)
2167 (* CodeRange : $44 *)
2168
2169 procedure Ins_WCVTP( args : PStorage );
2170 begin
2171 if (args^[0] < 0) or (args^[0] >= exc.cvtSize) then
2172 begin
2173 exc.error := TT_Err_Invalid_Reference;
2174 exit;
2175 end;
2176
2177 exc.func_write_cvt( args^[0], args^[1] );
2178 end;
2179
2180 (*******************************************)
2181 (* WCVTF[] : Write CVT in FUnits *)
2182 (* CodeRange : $70 *)
2183
2184 procedure Ins_WCVTF( args : PStorage );
2185 begin
2186 if (args^[0] < 0) or (args^[0] >= exc.cvtSize) then
2187 begin
2188 exc.error := TT_Err_Invalid_Reference;
2189 exit;
2190 end;
2191
2192 exc.cvt^[args^[0]] := Scale_Pixels(args^[1]);
2193 end;
2194
2195 (*******************************************)
2196 (* RCVT[] : Read CVT *)
2197 (* CodeRange : $45 *)
2198
2199 procedure Ins_RCVT( args : PStorage );
2200 begin
2201 if (args^[0] < 0) or (args^[0] >= exc.cvtSize) then
2202 begin
2203 exc.error := TT_Err_Invalid_Reference;
2204 exit;
2205 end;
2206
2207 args^[0] := exc.func_read_cvt(args^[0]);
2208 end;
2209
2210 (****************************************************************)
2211 (* *)
2212 (* MANAGING THE GRAPHICS STATE *)
2213 (* *)
2214 (* Instructions appear in the specs' order *)
2215 (* *)
2216 (****************************************************************)
2217
2218 (*******************************************)
2219 (* SVTCA[a] : Set F and P vectors to axis *)
2220 (* CodeRange : $00-$01 *)
2221
2222 procedure Ins_SVTCA( args : PStorage );
2223 var A, B : Short;
2224 begin
2225 case (exc.opcode and 1) of
2226 0 : A := $0000;
2227 1 : A := $4000;
2228 end;
2229 B := A xor $4000;
2230
2231 exc.GS.freeVector.x := A;
2232 exc.GS.projVector.x := A;
2233 exc.GS.dualVector.x := A;
2234
2235 exc.GS.freeVector.y := B;
2236 exc.GS.projVector.y := B;
2237 exc.GS.dualVector.y := B;
2238
2239 Compute_Funcs;
2240 end;
2241
2242 (*******************************************)
2243 (* SPVTCA[a] : Set PVector to Axis *)
2244 (* CodeRange : $02-$03 *)
2245
2246 procedure Ins_SPVTCA( args : PStorage );
2247 var A, B : Short;
2248 begin
2249 case (exc.opcode and 1) of
2250 0 : A := $0000;
2251 1 : A := $4000;
2252 end;
2253 B := A xor $4000;
2254
2255 exc.GS.projVector.x := A;
2256 exc.GS.dualVector.x := A;
2257
2258 exc.GS.projVector.y := B;
2259 exc.GS.dualVector.y := B;
2260
2261 Compute_Funcs;
2262 end;
2263
2264 (*******************************************)
2265 (* SFVTCA[a] : Set FVector to Axis *)
2266 (* CodeRange : $04-$05 *)
2267
2268 procedure Ins_SFVTCA( args : PStorage );
2269 var A, B : Short;
2270 begin
2271 case (exc.opcode and 1) of
2272 0 : A := $0000;
2273 1 : A := $4000;
2274 end;
2275 B := A xor $4000;
2276
2277 exc.GS.freeVector.x := A;
2278 exc.GS.freeVector.y := B;
2279
2280 Compute_Funcs;
2281 end;
2282
2283
2284
2285 function Ins_SxVTL( aIdx1 : Int;
2286 aIdx2 : Int;
2287 aOpc : Int;
2288 var Vec : TT_UnitVector ) : boolean;
2289 var
2290 A, B, C : Long;
2291 begin
2292 Ins_SxVTL := False;
2293
2294 with exc do
2295 begin
2296
2297 if (aIdx2 >= zp1.n_points) or (aIdx1 >= zp2.n_points) then
2298 begin
2299 Error := TT_Err_Invalid_Reference;
2300 exit;
2301 end;
2302
2303 with zp1.Cur^[aIdx2] do
2304 begin
2305 A := x;
2306 B := y;
2307 end;
2308
2309 with zp2.Cur^[aIdx1] do
2310 begin
2311 dec( A, x );
2312 dec( B, y );
2313 end;
2314
2315 if aOpc and 1 <> 0 then
2316 begin
2317 C := B; (* CounterClockwise rotation *)
2318 B := A;
2319 A := -C;
2320 end;
2321
2322 if not Normalize( A, B, Vec ) then
2323 begin
2324 exc.error := TT_Err_Ok;
2325 Vec.x := $4000;
2326 Vec.y := $0000;
2327 end;
2328
2329 Ins_SxVTL := True;
2330 end;
2331 end;
2332
2333
2334 (*******************************************)
2335 (* SPVTL[a] : Set PVector to Line *)
2336 (* CodeRange : $06-$07 *)
2337
2338 procedure Ins_SPVTL( args : PStorage );
2339 begin
2340 if not INS_SxVTL( args^[1],
2341 args^[0],
2342 exc.opcode,
2343 exc.GS.projVector ) then exit;
2344
2345 exc.GS.dualVector := exc.GS.projVector;
2346 Compute_Funcs;
2347 end;
2348
2349 (*******************************************)
2350 (* SFVTL[a] : Set FVector to Line *)
2351 (* CodeRange : $08-$09 *)
2352
2353 procedure Ins_SFVTL( args : PStorage );
2354 begin
2355 if not INS_SxVTL( args^[1],
2356 args^[0],
2357 exc.opcode,
2358 exc.GS.freeVector ) then exit;
2359
2360 Compute_Funcs;
2361 end;
2362
2363 (*******************************************)
2364 (* SFVTPV[] : Set FVector to PVector *)
2365 (* CodeRange : $0E *)
2366
2367 procedure Ins_SFVTPV( args : PStorage );
2368 begin
2369 exc.GS.freeVector := exc.GS.projVector;
2370 Compute_Funcs;
2371 end;
2372
2373 (*******************************************)
2374 (* SDPVTL[a] : Set Dual PVector to Line *)
2375 (* CodeRange : $86-$87 *)
2376
2377 procedure Ins_SDPVTL( args : PStorage );
2378 var
2379 A, B, C : Long;
2380 p1, p2 : Int;
2381 begin
2382
2383 p1 := args^[1];
2384 p2 := args^[0];
2385
2386 if (args^[0] < 0) or (args^[0] >= exc.zp1.n_points) or
2387 (args^[1] < 0) or (args^[1] >= exc.zp2.n_points) then
2388 begin
2389 exc.error := TT_Err_Invalid_Reference;
2390 exit;
2391 end;
2392
2393 A := exc.zp1.org^[p2].x - exc.zp2.org^[p1].x;
2394 B := exc.zp1.org^[p2].y - exc.zp2.org^[p1].y;
2395
2396 if exc.opcode and 1 <> 0 then
2397 begin
2398 C := B; (* CounterClockwise rotation *)
2399 B := A;
2400 A := -C;
2401 end;
2402
2403 Normalize( A, B, exc.GS.dualVector );
2404
2405 A := exc.zp1.cur^[p2].x - exc.zp2.cur^[p1].x;
2406 B := exc.zp1.cur^[p2].y - exc.zp2.cur^[p1].y;
2407
2408 if exc.opcode and 1 <> 0 then
2409 begin
2410 C := B; (* CounterClockwise rotation *)
2411 B := A;
2412 A := -C;
2413 end;
2414
2415 Normalize( A, B, exc.GS.projVector );
2416
2417 Compute_Funcs;
2418 exc.error := TT_Err_Ok;
2419 end;
2420
2421 (*******************************************)
2422 (* SPVFS[] : Set PVector From Stack *)
2423 (* CodeRange : $0A *)
2424
2425 procedure Ins_SPVFS( args : PStorage );
2426 var
2427 S : Short;
2428 X, Y : Long;
2429 begin
2430 S := args^[1]; Y := S; (* type conversion; extends sign *)
2431 S := args^[0]; X := S; (* type conversion; extends sign *)
2432
2433 if not Normalize( X, Y, exc.GS.projVector ) then exit;
2434
2435 exc.GS.dualVector := exc.GS.projVector;
2436
2437 Compute_Funcs;
2438 end;
2439
2440 (*******************************************)
2441 (* SFVFS[] : Set FVector From Stack *)
2442 (* CodeRange : $0B *)
2443
2444 procedure Ins_SFVFS( args : PStorage );
2445 var
2446 S : Short;
2447 X, Y : Long;
2448 begin
2449 S := args^[1]; Y := S; (* type conversion; extends sign *)
2450 S := args^[0]; X := S; (* type conversion; extends sign *)
2451
2452 if not Normalize( X, Y, exc.GS.freeVector ) then exit;
2453
2454 Compute_Funcs;
2455 end;
2456
2457 (*******************************************)
2458 (* GPV[] : Get Projection Vector *)
2459 (* CodeRange : $0C *)
2460
2461 procedure Ins_GPV( args : PStorage );
2462 begin
2463 args^[0] := exc.GS.projVector.x;
2464 args^[1] := exc.GS.projVector.y;
2465 end;
2466
2467 (*******************************************)
2468 (* GFV[] : Get Freedom Vector *)
2469 (* CodeRange : $0D *)
2470
2471 procedure Ins_GFV( args : PStorage );
2472 begin
2473 args^[0] := exc.GS.freeVector.x;
2474 args^[1] := exc.GS.freeVector.y;
2475 end;
2476
2477 (*******************************************)
2478 (* SRP0[] : Set Reference Point 0 *)
2479 (* CodeRange : $10 *)
2480
2481 procedure Ins_SRP0( args : PStorage );
2482 begin
2483 exc.GS.rp0 := args^[0];
2484 end;
2485
2486 (*******************************************)
2487 (* SRP1[] : Set Reference Point 1 *)
2488 (* CodeRange : $11 *)
2489
2490 procedure Ins_SRP1( args : PStorage );
2491 begin
2492 exc.GS.rp1 := args^[0];
2493 end;
2494
2495 (*******************************************)
2496 (* SRP2[] : Set Reference Point 2 *)
2497 (* CodeRange : $12 *)
2498
2499 procedure Ins_SRP2( args : PStorage );
2500 begin
2501 exc.GS.rp2 := args^[0];
2502 end;
2503
2504 (*******************************************)
2505 (* SZP0[] : Set Zone Pointer 0 *)
2506 (* CodeRange : $13 *)
2507
2508 procedure Ins_SZP0( args : PStorage );
2509 begin
2510 case args^[0] of
2511
2512 0 : exc.zp0 := exc.Twilight;
2513 1 : exc.zp0 := exc.Pts;
2514 else
2515 exc.error := TT_Err_Invalid_Reference;
2516 exit;
2517 end;
2518
2519 exc.GS.gep0 := args^[0];
2520 end;
2521
2522 (*******************************************)
2523 (* SZP1[] : Set Zone Pointer 1 *)
2524 (* CodeRange : $14 *)
2525
2526 procedure Ins_SZP1( args : PStorage );
2527 begin
2528 case args^[0] of
2529
2530 0 : exc.zp1 := exc.Twilight;
2531 1 : exc.zp1 := exc.Pts;
2532 else
2533 exc.error := TT_Err_Invalid_Reference;
2534 exit;
2535 end;
2536
2537 exc.GS.gep1 := args^[0];
2538 end;
2539
2540 (*******************************************)
2541 (* SZP2[] : Set Zone Pointer 2 *)
2542 (* CodeRange : $15 *)
2543
2544 procedure Ins_SZP2( args : PStorage );
2545 begin
2546 case args^[0] of
2547
2548 0 : exc.zp2 := exc.Twilight;
2549 1 : exc.zp2 := exc.Pts;
2550 else
2551 exc.error := TT_Err_Invalid_Reference;
2552 exit;
2553 end;
2554
2555 exc.GS.gep2 := args^[0];
2556 end;
2557
2558 (*******************************************)
2559 (* SZPS[] : Set Zone Pointers *)
2560 (* CodeRange : $16 *)
2561
2562 procedure Ins_SZPS( args : PStorage );
2563 begin
2564 case args^[0] of
2565
2566 0 : exc.zp0 := exc.Twilight;
2567 1 : exc.zp0 := exc.Pts;
2568 else
2569 exc.error := TT_Err_Invalid_Reference;
2570 exit;
2571 end;
2572
2573 exc.zp1 := exc.zp0;
2574 exc.zp2 := exc.zp0;
2575
2576 exc.GS.gep0 := args^[0];
2577 exc.GS.gep1 := args^[0];
2578 exc.GS.gep2 := args^[0];
2579 end;
2580
2581 (*******************************************)
2582 (* RTHG[] : Round To Half Grid *)
2583 (* CodeRange : $19 *)
2584
2585 procedure Ins_RTHG( args : PStorage );
2586 begin
2587 exc.GS.round_state := TT_Round_To_Half_Grid;
2588
2589 {$IFDEF FPK}
2590 exc.func_round := @Round_To_Half_Grid;
2591 {$ELSE}
2592 exc.func_round := Round_To_Half_Grid;
2593 {$ENDIF}
2594 end;
2595
2596 (*******************************************)
2597 (* RTG[] : Round To Grid *)
2598 (* CodeRange : $18 *)
2599
2600 procedure Ins_RTG( args : PStorage );
2601 begin
2602 exc.GS.round_state := TT_Round_To_Grid;
2603
2604 {$IFDEF FPK}
2605 exc.func_round := @Round_To_Grid;
2606 {$ELSE}
2607 exc.func_round := Round_To_Grid;
2608 {$ENDIF}
2609 end;
2610
2611 (*******************************************)
2612 (* RTDG[] : Round To Double Grid *)
2613 (* CodeRange : $3D *)
2614
2615 procedure Ins_RTDG( args : PStorage );
2616 begin
2617 exc.GS.round_state := TT_Round_To_Double_Grid;
2618
2619 {$IFDEF FPK}
2620 exc.func_round := @Round_To_Double_Grid;
2621 {$ELSE}
2622 exc.func_round := Round_To_Double_Grid;
2623 {$ENDIF}
2624 end;
2625
2626 (*******************************************)
2627 (* RUTG[] : Round Up To Grid *)
2628 (* CodeRange : $7C *)
2629
2630 procedure Ins_RUTG( args : PStorage );
2631 begin
2632 exc.GS.round_state := TT_Round_Up_To_Grid;
2633
2634 {$IFDEF FPK}
2635 exc.func_round := @Round_Up_To_Grid;
2636 {$ELSE}
2637 exc.func_round := Round_Up_To_Grid;
2638 {$ENDIF}
2639 end;
2640
2641 (*******************************************)
2642 (* RDTG[] : Round Down To Grid *)
2643 (* CodeRange : $7D *)
2644
2645 procedure Ins_RDTG( args : PStorage );
2646 begin
2647 exc.GS.round_state := TT_Round_Down_To_Grid;
2648
2649 {$IFDEF FPK}
2650 exc.func_round := @Round_Down_To_Grid;
2651 {$ELSE}
2652 exc.func_round := Round_Down_To_Grid;
2653 {$ENDIF}
2654 end;
2655
2656 (*******************************************)
2657 (* ROFF[] : Round OFF *)
2658 (* CodeRange : $7A *)
2659
2660 procedure Ins_ROFF( args : PStorage );
2661 begin
2662 exc.GS.round_state := TT_Round_Off;
2663
2664 {$IFDEF FPK}
2665 exc.func_round := @Round_None;
2666 {$ELSE}
2667 exc.func_round := Round_None;
2668 {$ENDIF}
2669 end;
2670
2671 (*******************************************)
2672 (* SROUND[] : Super ROUND *)
2673 (* CodeRange : $76 *)
2674
2675 procedure Ins_SROUND( args : PStorage );
2676 begin
2677 SetSuperRound( $4000, args^[0] );
2678 exc.GS.round_state := TT_Round_Super;
2679
2680 {$IFDEF FPK}
2681 exc.func_round := @Round_Super;
2682 {$ELSE}
2683 exc.func_round := Round_Super;
2684 {$ENDIF}
2685 end;
2686
2687 (*******************************************)
2688 (* S45ROUND[]: Super ROUND 45 degrees *)
2689 (* CodeRange : $77 *)
2690
2691 procedure Ins_S45ROUND( args : PStorage );
2692 begin
2693 SetSuperRound( $2D41, args^[0] );
2694 exc.GS.round_state := TT_Round_Super_45;
2695
2696 {$IFDEF FPK}
2697 exc.func_round := @Round_Super_45;
2698 {$ELSE}
2699 exc.func_round := Round_Super_45;
2700 {$ENDIF}
2701 end;
2702
2703
2704 (*******************************************)
2705 (* SLOOP[] : Set LOOP variable *)
2706 (* CodeRange : $17 *)
2707
2708 procedure Ins_SLOOP( args : PStorage );
2709 begin
2710 exc.GS.Loop := args^[0];
2711 end;
2712
2713 (*******************************************)
2714 (* SMD[] : Set Minimum Distance *)
2715 (* CodeRange : $1A *)
2716
2717 procedure Ins_SMD( args : PStorage );
2718 begin
2719 exc.GS.minimum_distance := args^[0];
2720 end;
2721
2722 (*******************************************)
2723 (* INSTCTRL[]: INSTruction ConTRol *)
2724 (* CodeRange : $8e *)
2725
2726 procedure Ins_INSTCTRL( args : PStorage );
2727 var
2728 K, L : Int;
2729 begin
2730 K := args^[1];
2731 L := args^[0];
2732
2733 if ( K < 1 ) or ( K > 2 ) then
2734 begin
2735 exc.error := TT_Err_Invalid_Reference;
2736 exit;
2737 end;
2738
2739 if L <> 0 then L := K;
2740
2741 exc.GS.instruct_control := ( exc.GS.instruct_control and not K ) or L;
2742 end;
2743
2744 (*******************************************)
2745 (* SCANCTRL[]: SCAN ConTRol *)
2746 (* CodeRange : $85 *)
2747
2748 procedure Ins_SCANCTRL( args : PStorage );
2749 var
2750 A : Int;
2751 begin
2752
2753 (* Get Threshold *)
2754 A := args^[0] and $FF;
2755
2756 if A = $FF then
2757 exc.GS.scan_Control := True
2758 else
2759 if A = 0 then
2760 exc.GS.scan_Control := False
2761 else
2762 begin
2763
2764 A := A * 64;
2765
2766 (* XXX TODO : Add rotation and stretch cases *)
2767
2768 if ( args^[0] and $100 <> 0 ) and
2769 ( exc.metrics.pointSize <= A ) then exc.GS.scan_Control := True;
2770
2771 if ( args^[0] and $200 <> 0 ) and
2772 ( false ) then exc.GS.scan_Control := True;
2773
2774 if ( args^[0] and $400 <> 0 ) and
2775 ( false ) then exc.GS.scan_Control := True;
2776
2777 if ( args^[0] and $800 <> 0 ) and
2778 ( exc.metrics.pointSize > A ) then exc.GS.scan_Control := False;
2779
2780 if ( args^[0] and $1000 <> 0 ) and
2781 ( not False ) then exc.GS.scan_Control := False;
2782
2783 if ( args^[0] and $2000 <> 0 ) and
2784 ( not False ) then exc.GS.scan_Control := False;
2785 end;
2786 end;
2787
2788 (*******************************************)
2789 (* SCANTYPE[]: SCAN TYPE *)
2790 (* CodeRange : $8D *)
2791
2792 procedure Ins_SCANTYPE( args : PStorage );
2793 begin
2794 (* For compatibility with future enhancements, *)
2795 (* we must ignore new modes *)
2796
2797 if (args^[0] >= 0 ) and (args^[0] <= 5) then
2798 begin
2799 if args^[0] = 3 then args^[0] := 2;
2800
2801 exc.GS.scan_type := args^[0];
2802 end;
2803 end;
2804
2805 (**********************************************)
2806 (* SCVTCI[] : Set Control Value Table Cut In *)
2807 (* CodeRange : $1D *)
2808
2809 procedure Ins_SCVTCI( args : PStorage );
2810 begin
2811 exc.GS.control_value_cutin := args^[0];
2812 end;
2813
2814 (**********************************************)
2815 (* SSWCI[] : Set Single Width Cut In *)
2816 (* CodeRange : $1E *)
2817
2818 procedure Ins_SSWCI( args : PStorage );
2819 begin
2820 exc.GS.single_width_cutin := args^[0];
2821 end;
2822
2823 (**********************************************)
2824 (* SSW[] : Set Single Width *)
2825 (* CodeRange : $1F *)
2826
2827 procedure Ins_SSW( args : PStorage );
2828 begin
2829 exc.GS.single_width_value := args^[0] div $400;
2830 end;
2831
2832 (**********************************************)
2833 (* FLIPON[] : Set Auto_flip to On *)
2834 (* CodeRange : $4D *)
2835
2836 procedure Ins_FLIPON( args : PStorage );
2837 begin
2838 exc.GS.auto_flip := True;
2839 end;
2840
2841 (**********************************************)
2842 (* FLIPOFF[] : Set Auto_flip to Off *)
2843 (* CodeRange : $4E *)
2844
2845 procedure Ins_FLIPOFF( args : PStorage );
2846 begin
2847 exc.GS.auto_flip := False;
2848 end;
2849
2850 (**********************************************)
2851 (* SANGW[] : Set Angle Weigth *)
2852 (* CodeRange : $7E *)
2853
2854 procedure Ins_SANGW( args : PStorage );
2855 begin
2856 (* instruction not supported anymore *)
2857 end;
2858
2859 (**********************************************)
2860 (* SDB[] : Set Delta Base *)
2861 (* CodeRange : $5E *)
2862
2863 procedure Ins_SDB( args : PStorage );
2864 begin
2865 exc.GS.delta_base := args^[0]
2866 end;
2867
2868 (**********************************************)
2869 (* SDS[] : Set Delta Shift *)
2870 (* CodeRange : $5F *)
2871
2872 procedure Ins_SDS( args : PStorage );
2873 begin
2874 exc.GS.delta_shift := args^[0]
2875 end;
2876
2877 (**********************************************)
2878 (* GC[a] : Get Coordinate projected onto *)
2879 (* CodeRange : $46-$47 *)
2880
2881 (* BULLSHIT : Measures from the original glyph must to be taken *)
2882 (* along the dual projection vector !! *)
2883
2884 procedure Ins_GC( args : PStorage );
2885 var
2886 L : Int;
2887 begin
2888 L := args^[0];
2889
2890 if (L < 0) or (L >= exc.zp2.n_points) then
2891 begin
2892 exc.error := TT_Err_Invalid_Reference;
2893 exit;
2894 end;
2895
2896 case exc.opcode and 1 of
2897
2898 0 : L := exc.func_project ( exc.zp2.cur^[L], Null_Vector );
2899 1 : L := exc.func_dualProj( exc.zp2.org^[L], Null_Vector );
2900 end;
2901
2902 args^[0] := L;
2903 end;
2904
2905 (**********************************************)
2906 (* SCFS[] : Set Coordinate From Stack *)
2907 (* CodeRange : $48 *)
2908 (* *)
2909 (* Formule : *)
2910 (* *)
2911 (* OA := OA + ( value - OA.p )/( f.p ) x f *)
2912 (* *)
2913
2914 procedure Ins_SCFS( args : PStorage );
2915 var
2916 K, L : Int;
2917 begin
2918 L := args^[0];
2919
2920 if (args^[0] < 0) or (args^[0] >= exc.zp2.n_points) then
2921 begin
2922 exc.error := TT_Err_Invalid_Reference;
2923 exit;
2924 end;
2925
2926 K := exc.func_project( exc.zp2.cur^[L], Null_Vector );
2927
2928 exc.func_move( @exc.zp2, L, args^[1] - K );
2929
2930 (* not part of the specs, but here for safety *)
2931
2932 if exc.GS.gep2 = 0 then
2933 exc.zp2.org^[L] := exc.zp2.cur^[L];
2934
2935 end;
2936
2937 (**********************************************)
2938 (* MD[a] : Measure Distance *)
2939 (* CodeRange : $49-$4A *)
2940
2941 (* BULLSHIT : Measure taken in the original glyph must be along *)
2942 (* the dual projection vector *)
2943
2944 (* Second BULLSHIT : Flag attributions are inverted !! *)
2945 (* 0 => measure distance in original outline *)
2946 (* 1 => measure distance in grid-fitted outline *)
2947
2948 procedure Ins_MD( args : PStorage );
2949 var
2950 K, L : Int;
2951 D : TT_F26dot6;
2952 vec1 : TT_Vector;
2953 vec2 : TT_Vector;
2954 begin
2955 K := args^[1];
2956 L := args^[0];
2957
2958 if (args^[0] < 0) or (args^[0] >= exc.zp0.n_points) or
2959 (args^[1] < 0) or (args^[1] >= exc.zp1.n_points) then
2960 begin
2961 exc.error := TT_Err_Invalid_Reference;
2962 exit;
2963 end;
2964
2965 case exc.opcode and 1 of
2966
2967 0 : D := exc.func_dualProj( exc.zp0.org^[L], exc.zp1.org^[K] );
2968 1 : D := exc.func_project ( exc.zp0.cur^[L], exc.zp1.cur^[K] );
2969 end;
2970
2971 args^[0] := D;
2972 end;
2973
2974 (**********************************************)
2975 (* MPPEM[] : Measure Pixel Per EM *)
2976 (* CodeRange : $4B *)
2977
2978 procedure Ins_MPPEM( args : PStorage );
2979 begin
2980 args^[0] := Get_Ppem;
2981 end;
2982
2983 (**********************************************)
2984 (* MPS[] : Measure PointSize *)
2985 (* CodeRange : $4C *)
2986
2987 procedure Ins_MPS( args : PStorage );
2988 begin
2989 args^[0] := exc.metrics.pointSize;
2990 end;
2991
2992 (****************************************************************)
2993 (* *)
2994 (* MANAGING OUTLINES *)
2995 (* *)
2996 (* Instructions appear in the specs' order *)
2997 (* *)
2998 (****************************************************************)
2999
3000
3001 (**********************************************)
3002 (* FLIPPT[] : FLIP PoinT *)
3003 (* CodeRange : $80 *)
3004
3005 procedure Ins_FLIPPT( args : PStorage );
3006 var
3007 point : Int;
3008 begin
3009 if exc.top < exc.GS.loop then
3010 begin
3011 exc.error := TT_Err_Too_Few_Arguments;
3012 exit;
3013 end;
3014
3015 while exc.GS.loop > 0 do
3016 begin
3017 dec( exc.args );
3018
3019 point := exc.stack^[ exc.args ];
3020
3021 if (point < 0) or (point >= exc.pts.n_points) then
3022 begin
3023 exc.error := TT_Err_Invalid_Reference;
3024 exit;
3025 end;
3026
3027 exc.pts.flags^[point] := exc.pts.flags^[point] xor TT_Flag_On_Curve;
3028
3029 dec( exc.GS.loop );
3030 end;
3031
3032 exc.GS.loop := 1;
3033 exc.new_top := exc.args;
3034 end;
3035
3036 (**********************************************)
3037 (* FLIPRGON[]: FLIP RanGe ON *)
3038 (* CodeRange : $81 *)
3039
3040 procedure Ins_FLIPRGON( args : PStorage );
3041 var
3042 I, K, L : Int;
3043 begin
3044 K := args^[1];
3045 L := args^[0];
3046
3047 if (K < 0) or (K >= exc.pts.n_points) or
3048 (L < 0) or (L >= exc.pts.n_points) then
3049 begin
3050 exc.error := TT_Err_Invalid_Reference;
3051 exit;
3052 end;
3053
3054 for I := L to K do
3055 exc.pts.flags^[I] := exc.pts.flags^[I] or TT_Flag_On_Curve;
3056 end;
3057
3058 (**********************************************)
3059 (* FLIPRGOFF : FLIP RanGe OFF *)
3060 (* CodeRange : $82 *)
3061
3062 procedure Ins_FLIPRGOFF( args : PStorage );
3063 var
3064 I, K, L : Int;
3065 begin
3066 K := args^[1];
3067 L := args^[0];
3068
3069 if (K < 0) or (K >= exc.pts.n_points) or
3070 (L < 0) or (L >= exc.pts.n_points) then
3071 begin
3072 exc.error := TT_Err_Invalid_Reference;
3073 exit;
3074 end;
3075
3076 for I := L to K do
3077 exc.pts.flags^[I] := exc.pts.flags^[I] and not TT_Flag_On_Curve;
3078 end;
3079
3080
3081
3082 function Compute_Point_Displacement( var x : TT_F26dot6;
3083 var y : TT_F26dot6;
3084 var zone : PGlyph_Zone;
3085 var refp : Int ) : TError;
3086 var
3087 zp : PGlyph_Zone;
3088 p : Int;
3089 d : TT_F26dot6;
3090 vec1 : TT_Vector;
3091 vec2 : TT_Vector;
3092 begin
3093
3094 Compute_Point_Displacement := Success;
3095
3096 case exc.opcode and 1 of
3097 0 : begin zp := @exc.zp1; p := exc.GS.rp2; end;
3098 1 : begin zp := @exc.zp0; p := exc.GS.rp1; end;
3099 end;
3100
3101 if (p < 0) or (p >= zp^.n_points) then
3102 begin
3103 exc.error := TT_Err_Invalid_Displacement;
3104 Compute_Point_Displacement := Failure;
3105 exit;
3106 end;
3107
3108 zone := zp;
3109 refp := p;
3110
3111 d := exc.func_project( zp^.cur^[p], zp^.org^[p] );
3112
3113 x := MulDiv_Round( d, Long(exc.GS.freeVector.x)*$10000, exc.F_dot_P );
3114 y := MulDiv_Round( d, Long(exc.GS.freeVector.y)*$10000, exc.F_dot_P );
3115
3116 end;
3117
3118
3119 procedure Move_Zp2_Point( point : Int;
3120 dx : TT_F26dot6;
3121 dy : TT_F26dot6 );
3122 begin
3123 if exc.GS.freeVector.x <> 0 then
3124 begin
3125 inc( exc.zp2.cur^[point].x, dx );
3126 exc.zp2.flags^[point] := exc.zp2.flags^[point] or TT_Flag_Touched_X;
3127 end;
3128
3129 if exc.GS.freeVector.y <> 0 then
3130 begin
3131 inc( exc.zp2.cur^[point].y, dy );
3132 exc.zp2.flags^[point] := exc.zp2.flags^[point] or TT_Flag_Touched_Y;
3133 end;
3134 end;
3135
3136 (**********************************************)
3137 (* SHP[a] : SHift Point by the last point *)
3138 (* CodeRange : $32-33 *)
3139
3140 procedure Ins_SHP( args : PStorage );
3141 var
3142 zp : PGlyph_Zone;
3143 refp : Int;
3144
3145 dx : TT_F26dot6;
3146 dy : TT_F26dot6;
3147 point: Int;
3148 begin
3149
3150 if Compute_Point_Displacement( dx, dy, zp, refp ) then
3151 exit;
3152
3153 if exc.top < exc.GS.loop then
3154 begin
3155 exc.error := TT_Err_Invalid_Reference;
3156 exit;
3157 end;
3158
3159 while exc.GS.loop > 0 do
3160 begin
3161
3162 dec( exc.args );
3163
3164 point := exc.stack^[ exc.args ];
3165
3166 if (point < 0) or (point >= exc.zp2.n_points) then
3167 begin
3168 exc.error := TT_Err_Invalid_Reference;
3169 exit;
3170 end;
3171
3172 Move_Zp2_Point( point, dx, dy );
3173
3174 dec( exc.GS.loop );
3175
3176 end;
3177
3178 exc.GS.loop := 1;
3179 exc.new_top := exc.args;
3180 end;
3181
3182 (**********************************************)
3183 (* SHC[a] : SHift Contour *)
3184 (* CodeRange : $34-35 *)
3185
3186 procedure Ins_SHC( args : PStorage );
3187 var
3188 zp : PGlyph_Zone;
3189 refp : Int;
3190 dx : TT_F26dot6;
3191 dy : TT_F26dot6;
3192
3193 contour, i : Int;
3194
3195 first_point, last_point : Int;
3196 begin
3197
3198 contour := args^[0];
3199
3200 if (args^[0] < 0) or (args^[0] >= exc.pts.n_contours ) then
3201 begin
3202 exc.error := TT_Err_Invalid_Reference;
3203 exit;
3204 end;
3205
3206 if Compute_Point_Displacement( dx, dy, zp, refp ) then
3207 exit;
3208
3209 if contour = 0 then first_point := 0 else
3210 first_point := exc.pts.conEnds^[contour-1]+1;
3211
3212 last_point := exc.pts.conEnds^[contour];
3213
3214 for i := first_point to last_point do
3215 begin
3216 if (zp^.cur <> exc.zp2.cur) or
3217 (refp <> i ) then
3218
3219 Move_Zp2_Point( i, dx, dy );
3220 end;
3221
3222 end;
3223
3224 (**********************************************)
3225 (* SHZ[a] : SHift Zone *)
3226 (* CodeRange : $36-37 *)
3227
3228 procedure Ins_SHZ( args : PStorage );
3229 var
3230 zp : PGlyph_Zone;
3231 refp : Int;
3232 dx : TT_F26dot6;
3233 dy : TT_F26dot6;
3234
3235 zone, i : Int;
3236
3237 last_point : Int;
3238 begin
3239
3240 zone := args^[0];
3241
3242 if (args^[0] < 0) or (args^[0] > 1) then
3243 begin
3244 exc.error := TT_Err_Invalid_Reference;
3245 exit;
3246 end;
3247
3248 if Compute_Point_Displacement( dx, dy, zp, refp ) then
3249 exit;
3250
3251 last_point := zp^.n_points-1;
3252
3253 for i := 0 to last_point do
3254 begin
3255 if (zp^.cur <> exc.zp2.cur) or
3256 (refp <> i ) then
3257
3258 Move_Zp2_Point( i, dx, dy );
3259 end;
3260
3261 end;
3262
3263 (**********************************************)
3264 (* SHPIX[] : SHift points by a PIXel amount *)
3265 (* CodeRange : $38 *)
3266
3267 procedure Ins_SHPIX( args : PStorage );
3268 var
3269 dx : TT_F26dot6;
3270 dy : TT_F26dot6;
3271 point: Int;
3272 begin
3273
3274 if exc.top < exc.GS.loop then
3275 begin
3276 exc.error := TT_Err_Invalid_Reference;
3277 exit;
3278 end;
3279
3280 dx := MulDiv_Round( args^[0],
3281 exc.GS.freeVector.x,
3282 $4000 );
3283
3284 dy := MulDiv_Round( args^[0],
3285 exc.GS.freeVector.y,
3286 $4000 );
3287
3288 while exc.GS.loop > 0 do
3289 begin
3290
3291 dec( exc.args );
3292
3293 point := exc.stack^[ exc.args ];
3294
3295 if (point < 0) or (point >= exc.zp2.n_points) then
3296 begin
3297 exc.error := TT_Err_Invalid_Reference;
3298 exit;
3299 end;
3300
3301 Move_Zp2_Point( point, dx, dy );
3302
3303 dec( exc.GS.loop );
3304
3305 end;
3306
3307 exc.GS.loop := 1;
3308 exc.new_top := exc.args;
3309 end;
3310
3311 (**********************************************)
3312 (* MSIRP[a] : Move Stack Indirect Relative *)
3313 (* CodeRange : $3A-$3B *)
3314
3315 procedure Ins_MSIRP( args : PStorage );
3316 var
3317 point : Int;
3318 distance : TT_F26dot6;
3319 vec1 : TT_Vector;
3320 vec2 : TT_Vector;
3321 begin
3322
3323 point := args^[0];
3324
3325 if (args^[0] < 0) or (args^[0] >= exc.zp1.n_points) then
3326 begin
3327 exc.error := TT_Err_Invalid_Reference;
3328 exit;
3329 end;
3330
3331 (* XXX : UNDOCUMENTED - Twilight Zone *)
3332
3333 (* Again, one stupid undocumented feature found in the *)
3334 (* twilight zone. What did these guys had in mind when *)
3335 (* they wrote the spec ? There _must_ be another *)
3336 (* specification than the published one !! #@%$& !! *)
3337
3338 if exc.GS.gep0 = 0 then (* if in twilight zone *)
3339 begin
3340 exc.zp1.org^[point] := exc.zp0.org^[exc.GS.rp0];
3341 exc.zp1.cur^[point] := exc.zp1.org^[point];
3342 end;
3343
3344 distance := exc.func_project( exc.zp1.cur^[point],
3345 exc.zp0.cur^[exc.GS.rp0] );
3346
3347 exc.func_move( @exc.zp1, point, args^[1] - distance );
3348
3349 exc.GS.rp1 := exc.GS.rp0;
3350 exc.GS.rp2 := point;
3351
3352 if exc.opcode and 1 <> 0 then exc.GS.rp0 := point;
3353 end;
3354
3355 (**********************************************)
3356 (* MDAP[a] : Move Direct Absolute Point *)
3357 (* CodeRange : $2E-$2F *)
3358
3359 procedure Ins_MDAP( args : PStorage );
3360 var
3361 point : Int;
3362 cur_dist : TT_F26dot6;
3363 distance : TT_F26dot6;
3364 begin
3365 point := args^[0];
3366
3367 if (args^[0] < 0) or (args^[0] >= exc.zp0.n_points) then
3368 begin
3369 exc.error := TT_Err_Invalid_Reference;
3370 exit;
3371 end;
3372
3373 (* XXXX Is there some undocumented feature while in the *)
3374 (* twilight zone ?? *)
3375
3376 if exc.opcode and 1 <> 0 then
3377 begin
3378
3379 cur_dist := exc.func_project( exc.zp0.cur^[point], Null_Vector );
3380
3381 distance := exc.func_round( cur_dist,
3382 exc.metrics.compensations[0] ) -
3383 cur_dist;
3384 end
3385 else
3386 distance := 0;
3387
3388 exc.func_move( @exc.zp0, point, distance );
3389
3390 exc.GS.rp0 := point;
3391 exc.GS.rp1 := point;
3392 end;
3393
3394 (**********************************************)
3395 (* MIAP[a] : Move Indirect Absolute Point *)
3396 (* CodeRange : $3E-$3F *)
3397
3398 procedure Ins_MIAP( args : PStorage );
3399 var
3400 cvtEntry : Int;
3401 point : Int;
3402 distance : TT_F26dot6;
3403 org_dist : TT_F26dot6;
3404 begin
3405 cvtEntry := args^[1];
3406 point := args^[0];
3407
3408 if (args^[0] < 0) or (args^[0] >= exc.zp0.n_points ) or
3409 (args^[1] < 0) or (args^[1] >= exc.cvtSize) then
3410 begin
3411 exc.error := TT_Err_Invalid_Reference;
3412 exit;
3413 end;
3414
3415 (* Undocumented : *)
3416 (* *)
3417 (* The behaviour of an MIAP instruction is quite *)
3418 (* different when used in the twilight zone^. *)
3419 (* *)
3420 (* First, no control value cutin test is performed *)
3421 (* as it would fail anyway. Second, the original *)
3422 (* point, i.e. (org_x,org_y) of zp0.point, is set *)
3423 (* to the absolute, unrounded, distance found in *)
3424 (* the CVT. *)
3425 (* *)
3426 (* This is used in the CVT programs of the Microsoft *)
3427 (* fonts Arial, Times, etc.., in order to re-adjust *)
3428 (* some key font heights. It allows the use of the *)
3429 (* IP instruction in the twilight zone, which *)
3430 (* otherwise would be "illegal" per se the specs :) *)
3431 (* *)
3432 (* We implement it with a special sequence for the *)
3433 (* twilight zone. This is a bad hack, but it seems *)
3434 (* to work.. *)
3435 (* - David *)
3436
3437 distance := exc.func_read_cvt(cvtEntry);
3438
3439 if exc.GS.gep0 = 0 then (* If in twilight zone *)
3440 begin
3441 exc.zp0.org^[point].y := MulDiv_Round( exc.GS.freeVector.x,
3442 distance,
3443 $4000 );
3444
3445 exc.zp0.org^[point].y := MulDiv_Round( exc.GS.freeVector.y,
3446 distance,
3447 $4000 );
3448
3449 exc.zp0.cur^[point] := exc.zp0.org^[point];
3450 end;
3451
3452 org_dist := exc.func_project( exc.zp0.cur^[point], Null_Vector );
3453
3454 if exc.opcode and 1 <> 0 then (* rounding and control cutin flag *)
3455 begin
3456
3457 if abs( distance-org_dist ) > exc.GS.control_value_cutin then
3458 distance := org_dist;
3459
3460 distance := exc.func_round( distance,
3461 exc.metrics.compensations[0] );
3462 end;
3463
3464 exc.func_move( @exc.zp0, point, distance - org_dist );
3465
3466 exc.GS.rp0 := point;
3467 exc.GS.rp1 := point;
3468
3469 end;
3470
3471 (**********************************************)
3472 (* MDRP[abcde] : Move Direct Relative Point *)
3473 (* CodeRange : $C0-$DF *)
3474
3475 procedure Ins_MDRP( args : PStorage );
3476 var
3477 point : Int;
3478 distance : TT_F26dot6;
3479 org_dist : TT_F26dot6;
3480 begin
3481 point := args^[0];
3482
3483 if (args^[0] < 0) or (args^[0] >= exc.zp1.n_points) then
3484 begin
3485 exc.error := TT_Err_Invalid_Reference;
3486 exit;
3487 end;
3488
3489 (* XXXX Is there some undocumented feature while in the *)
3490 (* twilight zone ?? *)
3491
3492 org_dist := exc.func_dualProj( exc.zp1.org^[point],
3493 exc.zp0.org^[exc.GS.rp0] );
3494 (* single width cutin test *)
3495
3496 if abs(org_dist) < exc.GS.single_width_cutin then
3497
3498 if org_dist >= 0 then org_dist := exc.GS.single_width_value
3499 else org_dist := -exc.GS.single_width_value;
3500
3501 (* round flag *)
3502
3503 if exc.opcode and 4 <> 0 then
3504
3505 distance := exc.func_round( org_dist,
3506 exc.metrics.compensations[ exc.opcode and 3 ] )
3507 else
3508 distance := Round_None( org_dist,
3509 exc.metrics.compensations[ exc.opcode and 3 ] );
3510
3511 (* minimum distance flag *)
3512
3513 if exc.opcode and 8 <> 0 then
3514 begin
3515
3516 if org_dist >= 0 then
3517
3518 if distance < exc.GS.minimum_distance then
3519 distance := exc.GS.minimum_distance
3520 else
3521 else
3522 if distance > -exc.GS.minimum_distance then
3523 distance := -exc.GS.minimum_distance;
3524 end;
3525
3526 (* now move the point *)
3527
3528 org_dist := exc.func_project( exc.zp1.cur^[point],
3529 exc.zp0.cur^[exc.GS.rp0] );
3530
3531 exc.func_move( @exc.zp1, point, distance - org_dist );
3532
3533 exc.GS.rp1 := exc.GS.rp0;
3534 exc.GS.rp2 := point;
3535
3536 if exc.opcode and 16 <> 0 then exc.GS.rp0 := point;
3537 end;
3538
3539 (**********************************************)
3540 (* MIRP[abcde] : Move Indirect Relative Point *)
3541 (* CodeRange : $E0-$FF *)
3542
3543 procedure Ins_MIRP( args : PStorage );
3544 var
3545 point : Int;
3546 cvtEntry : Int;
3547 cvt_dist : TT_F26dot6;
3548 distance : TT_F26dot6;
3549 cur_dist : TT_F26dot6;
3550 org_dist : TT_F26dot6;
3551 begin
3552
3553 point := args^[0];
3554 cvtEntry := args^[1];
3555
3556 (* XXX : UNDOCUMENTED => cvt[-1] = 0 ???? *)
3557
3558 if (args^[0] < 0 ) or (args^[0] >= exc.zp1.n_points) or
3559 (args^[1] < -1) or (args^[1] >= exc.cvtSize) then
3560 begin
3561 exc.error := TT_Err_Invalid_Reference;
3562 exit;
3563 end;
3564
3565 if cvtEntry < 0 then
3566 cvt_dist := 0
3567 else
3568 cvt_dist := exc.func_read_cvt(cvtEntry);
3569
3570 (* single width test *)
3571
3572 if abs(cvt_dist) < exc.GS.single_width_cutin then
3573
3574 if cvt_dist >= 0 then cvt_dist := exc.GS.single_width_value
3575 else cvt_dist := -exc.GS.single_width_value;
3576
3577 (* XXX : Undocumented - twilight zone *)
3578
3579 if exc.GS.gep1 = 0 then (* if in twilight zone *)
3580 begin
3581 exc.zp1.org^[point].x := exc.zp0.org^[exc.GS.rp0].x +
3582 MulDiv_Round( cvt_dist,
3583 exc.GS.freeVector.x,
3584 $4000 );
3585
3586 exc.zp1.org^[point].x := exc.zp0.org^[exc.GS.rp0].y +
3587 MulDiv_Round( cvt_dist,
3588 exc.GS.freeVector.y,
3589 $4000 );
3590
3591 exc.zp1.cur^[point] := exc.zp1.org^[point];
3592 end;
3593
3594
3595 org_dist := exc.func_dualProj( exc.zp1.org^[point],
3596 exc.zp0.org^[exc.GS.rp0] );
3597
3598 cur_dist := exc.func_Project( exc.zp1.cur^[point],
3599 exc.zp0.cur^[exc.GS.rp0] );
3600
3601 (* auto-flip test *)
3602
3603 if exc.GS.auto_flip then
3604 if (org_dist xor cvt_dist < 0) then
3605 cvt_dist := -cvt_dist;
3606
3607 (* control value cutin and round *)
3608
3609 if exc.opcode and 4 <> 0 then
3610 begin
3611 (* XXX : UNDOCUMENTED : only perform cut-in test when both *)
3612 (* zone pointers refer to the points zone *)
3613
3614 if exc.GS.gep0 = exc.GS.gep1 then
3615 if abs( cvt_dist - org_dist ) >= exc.GS.control_value_cutin then
3616 cvt_dist := org_dist;
3617
3618 distance := exc.func_round( cvt_dist,
3619 exc.metrics.compensations[ exc.opcode and 3 ] );
3620 end
3621 else
3622 distance := Round_None( cvt_dist,
3623 exc.metrics.compensations[ exc.opcode and 3 ] );
3624
3625 (* minimum distance test *)
3626
3627 if exc.opcode and 8 <> 0 then
3628 begin
3629 if org_dist >= 0 then
3630
3631 if distance < exc.GS.minimum_distance then
3632 distance := exc.GS.minimum_distance
3633 else
3634 else
3635 if distance > -exc.GS.minimum_distance then
3636 distance := -exc.GS.minimum_distance;
3637 end;
3638
3639 exc.func_move( @exc.zp1, point, distance - cur_dist );
3640
3641 exc.GS.rp1 := exc.GS.rp0;
3642
3643 if exc.opcode and 16 <> 0 then exc.GS.rp0 := point;
3644
3645 (* UNDOCUMENTED !! *)
3646
3647 exc.GS.rp2 := point;
3648 end;
3649
3650 (**********************************************)
3651 (* ALIGNRP[] : ALIGN Relative Point *)
3652 (* CodeRange : $3C *)
3653
3654 procedure Ins_ALIGNRP( args : PStorage );
3655 var
3656 point : Int;
3657 distance : TT_F26dot6;
3658 begin
3659 if exc.top < exc.GS.loop then
3660 begin
3661 exc.error := TT_Err_Invalid_Reference;
3662 exit;
3663 end;
3664
3665 while exc.GS.loop > 0 do
3666 begin
3667
3668 dec( exc.args );
3669
3670 point := exc.stack^[ exc.args ];
3671
3672 if (point < 0) or (point >= exc.zp1.n_points) then
3673 begin
3674 exc.error := TT_Err_Invalid_Reference;
3675 exit;
3676 end;
3677
3678 distance := exc.func_project( exc.zp1.cur^[point],
3679 exc.zp0.cur^[exc.GS.rp0] );
3680
3681 exc.func_move( @exc.zp1, point, -distance );
3682
3683 dec( exc.GS.loop );
3684 end;
3685
3686 exc.GS.loop := 1;
3687 exc.new_top := exc.args;
3688 end;
3689
3690 (**********************************************)
3691 (* AA[] : Adjust Angle *)
3692 (* CodeRange : $7F *)
3693
3694 procedure Ins_AA( args : PStorage );
3695 begin
3696 (* Intentional - no longer supported *)
3697 end;
3698
3699 (**********************************************)
3700 (* ISECT[] : moves point to InterSECTion *)
3701 (* CodeRange : $0F *)
3702
3703 procedure Ins_ISECT( args : PStorage );
3704 var
3705 point : Int;
3706 a0, a1 : Int;
3707 b0, b1 : Int;
3708
3709 discriminant : TT_F26dot6;
3710 dx, dy,
3711 dax, day,
3712 dbx, dby : TT_F26dot6;
3713
3714 val : TT_F26dot6;
3715
3716 R : TT_Vector;
3717
3718 U, V : TT_UnitVector;
3719 T1, T2 : Int64;
3720 begin
3721
3722 point := args^[0];
3723 a0 := args^[1];
3724 a1 := args^[2];
3725 b0 := args^[3];
3726 b1 := args^[4];
3727
3728 if (b0 >= exc.zp0.n_points) or (b1 >= exc.zp0.n_points) or
3729 (a0 >= exc.zp1.n_points) or (a1 >= exc.zp1.n_points) or
3730 (point >= exc.zp0.n_points) then
3731 begin
3732 exc.error := TT_Err_Invalid_Reference;
3733 exit;
3734 end;
3735 (*
3736 if Normalize( exc.zp1.cur_x^[a1] - exc.zp1.cur_x^[a0],
3737 exc.zp1.cur_y^[a1] - exc.zp1.cur_y^[a0],
3738 U )
3739 and
3740 Normalize( - exc.zp0.cur_x^[b1] - exc.zp0.cur_x^[b0],
3741 exc.zp0.cur_y^[b1] - exc.zp0.cur_y^[b0],
3742 V )
3743 then
3744 begin
3745
3746 dx := MulDiv_Round( exc.zp0.cur_x^[b0] -
3747 exc.zp1.cur_x^[a0],
3748 V.x,
3749 $4000 ) +
3750
3751 MulDiv_Round( exc.zp0.cur_y^[b0] -
3752 exc.zp1.cur_y^[a0],
3753 V.y,
3754 $4000 );
3755
3756 dy := MulDiv_Round( U.x, V.x, $4000 ) +
3757 MulDiv_Round( U.y, V.y, $4000 );
3758
3759 if dy <> 0 then
3760 begin
3761 dx := MulDiv_Round( dx, $4000, dy );
3762
3763 exc.zp2.flags^[point] := exc.zp2.flags^[point] or
3764 TT_Flag_Touched_Both;
3765
3766 exc.zp2.cur_x^[point] := exc.zp1.cur_x^[a0] +
3767
3768 MulDiv_Round( dx, U.x, $4000 );
3769
3770 exc.zp2.cur_y^[point] := exc.zp1.cur_y^[a0] +
3771
3772 MulDiv_Round( dx, U.y, $4000 );
3773
3774 exit;
3775 end;
3776 end;
3777 *)
3778 dbx := exc.zp0.cur^[b1].x - exc.zp0.cur^[b0].x;
3779 dby := exc.zp0.cur^[b1].y - exc.zp0.cur^[b0].y;
3780
3781 dax := exc.zp1.cur^[a1].x - exc.zp1.cur^[a0].x;
3782 day := exc.zp1.cur^[a1].y - exc.zp1.cur^[a0].y;
3783
3784 dx := exc.zp0.cur^[b0].x - exc.zp1.cur^[a0].x;
3785 dy := exc.zp0.cur^[b0].y - exc.zp1.cur^[a0].y;
3786
3787 exc.zp2.flags^[point] := exc.zp2.flags^[point] or
3788 TT_Flag_Touched_Both;
3789
3790 discriminant := MulDiv( dax, -dby, $40 ) +
3791 MulDiv( day, dbx, $40 );
3792
3793 if abs(discriminant) >= $40 then
3794 begin
3795
3796 val := MulDiv( dx, -dby, $40 ) +
3797 MulDiv( dy, dbx, $40 );
3798
3799 R.x := MulDiv( val, dax, discriminant );
3800 R.y := MulDiv( val, day, discriminant );
3801
3802 exc.zp2.cur^[point].x := exc.zp1.cur^[a0].x + R.x;
3803 exc.zp2.cur^[point].y := exc.zp1.cur^[a0].y + R.y;
3804 end
3805 else
3806 begin
3807
3808 (* else, take the middle of the middles of A and B *)
3809
3810 exc.zp2.cur^[point].x := ( exc.zp1.cur^[a0].x +
3811 exc.zp1.cur^[a1].x +
3812 exc.zp0.cur^[b0].x +
3813 exc.zp0.cur^[b1].x ) div 4;
3814
3815 exc.zp2.cur^[point].y := ( exc.zp1.cur^[a0].y +
3816 exc.zp1.cur^[a1].y +
3817 exc.zp0.cur^[b0].y +
3818 exc.zp0.cur^[b1].y ) div 4;
3819 end;
3820 end;
3821
3822 (**********************************************)
3823 (* ALIGNPTS[] : ALIGN PoinTS *)
3824 (* CodeRange : $27 *)
3825
3826 procedure Ins_ALIGNPTS( args : PStorage );
3827 var
3828 p1, p2 : Int;
3829 distance : TT_F26dot6;
3830 begin
3831 p1 := args^[0];
3832 p2 := args^[1];
3833
3834 if (args^[0] < 0) or (args^[0] >= exc.zp1.n_points) or
3835 (args^[1] < 0) or (args^[1] >= exc.zp0.n_points) then
3836 begin
3837 exc.error := TT_Err_Invalid_Reference;
3838 exit;
3839 end;
3840
3841 distance := exc.func_project( exc.zp0.cur^[p2],
3842 exc.zp1.cur^[p1] ) div 2;
3843
3844 exc.func_move( @exc.zp1, p1, distance );
3845 exc.func_move( @exc.zp0, p2, -distance );
3846 end;
3847
3848 (**********************************************)
3849 (* IP[] : Interpolate Point *)
3850 (* CodeRange : $39 *)
3851
3852 procedure Ins_IP( args : PStorage );
3853 var
3854 org_a : TT_F26dot6;
3855 org_b : TT_F26dot6;
3856 org_x : TT_F26dot6;
3857 cur_a : TT_F26dot6;
3858 cur_b : TT_F26dot6;
3859 cur_x : TT_F26dot6;
3860
3861 distance : TT_F26dot6;
3862
3863 point : Int;
3864 begin
3865
3866 if exc.top < exc.GS.loop then
3867 begin
3868 exc.error := TT_Err_Invalid_Reference;
3869 exit;
3870 end;
3871
3872 org_a := exc.func_dualProj( exc.zp0.org^[exc.GS.rp1], Null_Vector );
3873
3874 org_b := exc.func_dualProj( exc.zp1.org^[exc.GS.rp2], Null_Vector );
3875
3876 cur_a := exc.func_project( exc.zp0.cur^[exc.GS.rp1], Null_Vector );
3877
3878 cur_b := exc.func_project( exc.zp1.cur^[exc.GS.rp2], Null_Vector );
3879
3880 while exc.GS.loop > 0 do
3881 begin
3882
3883 dec( exc.args );
3884
3885 point := exc.stack^[ exc.args ];
3886
3887 org_x := exc.func_dualProj( exc.zp2.org^[point], Null_Vector );
3888
3889 cur_x := exc.func_project( exc.zp2.cur^[point], Null_Vector );
3890
3891 if (( org_a <= org_b ) and ( org_x <= org_a )) or
3892 (( org_a > org_b ) and ( org_x >= org_a )) then
3893 begin
3894 distance := ( cur_a - org_a ) + ( org_x - cur_x );
3895 end
3896 else
3897 if (( org_a <= org_b ) and ( org_x >= org_b )) or
3898 (( org_a > org_b ) and ( org_x < org_b )) then
3899 begin
3900 distance := ( cur_b - org_b ) + ( org_x - cur_x );
3901 end
3902 else
3903 begin
3904 (* note : it seems that rounding this value isn't a good *)
3905 (* idea ( width of capital 'S' in Times *)
3906
3907 distance := MulDiv( cur_b - cur_a,
3908 org_x - org_a,
3909 org_b - org_a ) + ( cur_a - cur_x );
3910 end;
3911
3912 exc.func_move( @exc.zp2, point, distance );
3913
3914 dec( exc.GS.loop );
3915 end;
3916
3917 exc.GS.loop := 1;
3918 exc.new_top := exc.args;
3919 end;
3920
3921 (**********************************************)
3922 (* UTP[a] : UnTouch Point *)
3923 (* CodeRange : $29 *)
3924
3925 procedure Ins_UTP( args : PStorage );
3926 var
3927 mask : Byte;
3928 begin
3929 if (args^[0] < 0) or (args^[0] >= exc.zp0.n_points) then
3930 begin
3931 exc.error := TT_Err_Invalid_Reference;
3932 exit;
3933 end;
3934
3935 mask := $FF;
3936
3937 if exc.GS.freeVector.x <> 0 then mask := mask and not TT_Flag_Touched_X;
3938 if exc.GS.freeVector.y <> 0 then mask := mask and not TT_Flag_Touched_Y;
3939
3940 exc.zp0.flags^[args^[0]] := exc.zp0.flags^[args^[0]] and mask;
3941 end;
3942
3943 (**********************************************)
3944 (* IUP[a] : Interpolate Untouched Points *)
3945 (* CodeRange : $30-$31 *)
3946
3947 procedure Ins_IUP( args : PStorage );
3948 var
3949 mask : byte;
3950
3951 first_point, (* first point of contour *)
3952 end_point, (* end point (last+1) of contour *)
3953
3954 first_touched, (* first touched point in contour *)
3955 cur_touched, (* current touched point in contour *)
3956
3957 point, (* current point *)
3958 contour : Int; (* current contour *)
3959
3960 orgs, (* original and current coordinate *)
3961 curs : TT_Points; (* arrays *)
3962
3963 procedure Shift_X( p1, p2, p : Int );
3964 var
3965 i : Int;
3966 x : TT_F26dot6;
3967 begin
3968 x := curs^[p].x - orgs^[p].x;
3969
3970 for i := p1 to p-1 do inc( curs^[i].x, x );
3971 for i := p+1 to p2 do inc( curs^[i].x, x );
3972 end;
3973
3974 procedure Shift_Y( p1, p2, p : Int );
3975 var
3976 i : Int;
3977 y : TT_F26dot6;
3978 begin
3979 y := curs^[p].y - orgs^[p].y;
3980
3981 for i := p1 to p-1 do inc( curs^[i].y, y );
3982 for i := p+1 to p2 do inc( curs^[i].y, y );
3983 end;
3984
3985
3986 procedure Interp_X( p1, p2, ref1, ref2 : Int );
3987 var
3988 i : Int;
3989 x, x1, x2, d1, d2 : TT_F26dot6;
3990 begin
3991
3992 if p1 > p2 then exit;
3993
3994 x1 := orgs^[ref1].x; d1 := curs^[ref1].x - orgs^[ref1].x;
3995 x2 := orgs^[ref2].x; d2 := curs^[ref2].x - orgs^[ref2].x;
3996
3997 if x1 = x2 then
3998 for i := p1 to p2 do
3999 begin
4000 x := orgs^[i].x;
4001 if x <= x1 then x := x + d1
4002 else x := x + d2;
4003
4004 curs^[i].x := x;
4005 end
4006
4007 else
4008 if x1 < x2 then
4009
4010 for i := p1 to p2 do
4011 begin
4012 x := orgs^[i].x;
4013
4014 if (x <= x1) then x := x + d1
4015 else
4016 if (x >= x2) then x := x + d2
4017 else
4018 x := curs^[ref1].x +
4019 MulDiv( x-x1, curs^[ref2].x-curs^[ref1].x, x2-x1 );
4020
4021 curs^[i].x := x;
4022 end
4023 else
4024
4025 (* x2 < x1 *)
4026
4027 for i := p1 to p2 do
4028 begin
4029 x := orgs^[i].x;
4030
4031 if ( x <= x2 ) then x := x + d2
4032 else
4033 if ( x >= x1 ) then x := x + d1
4034 else
4035 x := curs^[ref1].x +
4036 MulDiv( x-x1, curs^[ref2].x-curs^[ref1].x, x2-x1 );
4037
4038 curs^[i].x := x;
4039 end;
4040 end;
4041
4042 procedure Interp_Y( p1, p2, ref1, ref2 : Int );
4043 var
4044 i : Int;
4045 y, y1, y2, d1, d2 : TT_F26dot6;
4046 begin
4047
4048 if p1 > p2 then exit;
4049
4050 y1 := orgs^[ref1].y; d1 := curs^[ref1].y - orgs^[ref1].y;
4051 y2 := orgs^[ref2].y; d2 := curs^[ref2].y - orgs^[ref2].y;
4052
4053 if y1 = y2 then
4054 for i := p1 to p2 do
4055 begin
4056 y := orgs^[i].y;
4057 if y <= y1 then y := y + d1
4058 else y := y + d2;
4059
4060 curs^[i].y := y;
4061 end
4062
4063 else
4064 if y1 < y2 then
4065
4066 for i := p1 to p2 do
4067 begin
4068 y := orgs^[i].y;
4069
4070 if (y <= y1) then y := y + d1
4071 else
4072 if (y >= y2) then y := y + d2
4073 else
4074 y := curs^[ref1].y +
4075 MulDiv( y-y1, curs^[ref2].y-curs^[ref1].y, y2-y1 );
4076
4077 curs^[i].y := y;
4078 end
4079 else
4080
4081 (* y2 < y1 *)
4082
4083 for i := p1 to p2 do
4084 begin
4085 y := orgs^[i].y;
4086
4087 if ( y <= y2 ) then y := y + d2
4088 else
4089 if ( y >= y1 ) then y := y + d1
4090 else
4091 y := curs^[ref1].y +
4092 MulDiv( y-y1, curs^[ref2].y-curs^[ref1].y, y2-y1 );
4093
4094 curs^[i].y := y;
4095 end;
4096 end;
4097
4098 begin
4099 orgs := exc.pts.org;
4100 curs := exc.pts.cur;
4101
4102 case exc.opcode and 1 of
4103 0 : mask := TT_Flag_Touched_Y;
4104 1 : mask := TT_Flag_Touched_X;
4105 end;
4106
4107 with exc do
4108 begin
4109
4110 contour := 0;
4111 point := 0;
4112
4113 repeat
4114
4115 end_point := pts.conEnds^[contour];
4116 first_point := point;
4117
4118 while ( point <= end_point ) and
4119 ( pts.flags^[point] and mask = 0 ) do inc(point);
4120
4121 if point <= end_point then
4122 begin
4123
4124 first_touched := point;
4125 cur_touched := point;
4126
4127 inc( point );
4128
4129 while ( point <= end_point ) do
4130 begin
4131 if pts.flags^[point] and mask <> 0 then
4132 begin
4133 if opcode and 1 <> 0 then
4134 Interp_X( cur_touched+1, point-1, cur_touched, point )
4135 else
4136 Interp_Y( cur_touched+1, point-1, cur_touched, point );
4137
4138 cur_touched := point;
4139 end;
4140
4141 inc( point );
4142 end;
4143
4144 if cur_touched = first_touched then
4145 if opcode and 1 <> 0 then
4146 Shift_X( first_point, end_point, cur_touched )
4147 else
4148 Shift_Y( first_point, end_point, cur_touched )
4149 else
4150 begin
4151 if opcode and 1 <> 0 then
4152 begin
4153 interp_x( cur_touched+1, end_point, cur_touched, first_touched );
4154 interp_x( first_point, first_touched-1, cur_touched, first_touched );
4155 end
4156 else
4157 begin
4158 interp_y( cur_touched+1, end_point, cur_touched, first_touched );
4159 interp_y( first_point, first_touched-1, cur_touched, first_touched );
4160 end;
4161 end;
4162
4163 end;
4164
4165 inc( contour );
4166
4167 until contour >= pts.n_contours;
4168
4169 end;
4170
4171 end;
4172
4173 (**********************************************)
4174 (* DELTAPn[] : DELTA Exceptions P1, P2, P3 *)
4175 (* CodeRange : $5D,$71,$72 *)
4176
4177 procedure Ins_DELTAP( args : PStorage );
4178 var
4179 nump : Int;
4180 k : Int;
4181 A, B, C :Int;
4182 begin
4183
4184 nump := args^[0];
4185
4186 for K := 1 to nump do
4187 begin
4188 if exc.args < 2 then
4189 begin
4190 exc.error := TT_Err_Too_Few_Arguments;
4191 exit;
4192 end;
4193
4194 dec( exc.args, 2 );
4195
4196 A := exc.stack^[exc.args+1];
4197 B := exc.stack^[ exc.args ];
4198
4199 (* XXX : *)
4200 (* some commonly fonts have broke programs where the *)
4201 (* the point reference has an invalid value. Here, we *)
4202 (* simply ignore them, because a DeltaP won't change *)
4203 (* a glyph shape dramatically.. *)
4204 (* *)
4205
4206 if A < exc.zp0.n_points then
4207 begin
4208 C := ( B and $F0 ) shr 4;
4209
4210 Case exc.opcode of
4211 $5D : ;
4212 $71 : C := C+16;
4213 $72 : C := C+32;
4214 end;
4215
4216 C := C + exc.GS.delta_Base;
4217
4218 if GET_Ppem = C then
4219 begin
4220 B := (B and $F) - 8;
4221 if B >= 0 then B := B+1;
4222 B := ( B*64 ) div ( 1 shl exc.GS.delta_Shift );
4223
4224 exc.func_move( @exc.zp0, A, B );
4225 end;
4226 end;
4227
4228 end;
4229
4230 exc.new_top := exc.args;
4231 end;
4232
4233
4234 (**********************************************)
4235 (* DELTACn[] : DELTA Exceptions C1, C2, C3 *)
4236 (* CodeRange : $73,$74,$75 *)
4237
4238 procedure Ins_DELTAC( args : PStorage );
4239 var
4240 nump : Int;
4241 k : Int;
4242 A, B, C :Int;
4243 begin
4244
4245 nump := args^[0];
4246
4247 for K := 1 to nump do
4248 begin
4249 if exc.args < 2 then
4250 begin
4251 exc.error := TT_Err_Too_Few_Arguments;
4252 exit;
4253 end;
4254
4255 dec( exc.args, 2 );
4256
4257 A := exc.stack^[exc.args+1];
4258 B := exc.stack^[ exc.args ];
4259
4260 if A >= exc.cvtSize then
4261 begin
4262 exc.error := TT_Err_Invalid_Reference;
4263 exit;
4264 end;
4265
4266 C := ( B and $F0 ) shr 4;
4267
4268 Case exc.opcode of
4269 $73 : ;
4270 $74 : C := C+16;
4271 $75 : C := C+32;
4272 end;
4273
4274 C := C + exc.GS.delta_Base;
4275
4276 if GET_Ppem = C then
4277 begin
4278 B := (B and $F) - 8;
4279 if B >= 0 then B := B+1;
4280 B := ( B*64 ) div ( 1 shl exc.GS.delta_Shift );
4281
4282 exc.func_move_cvt( A, B );
4283 end;
4284 end;
4285
4286 exc.new_top := exc.args;
4287 end;
4288
4289 (****************************************************************)
4290 (* *)
4291 (* MISC. INSTRUCTIONS *)
4292 (* *)
4293 (****************************************************************)
4294
4295 (***********************************************************)
4296 (* DEBUG[] : DEBUG. Unsupported *)
4297 (* CodeRange : $4F *)
4298
4299 (* NOTE : The original instruction pops a value from the stack *)
4300
4301 procedure Ins_DEBUG( args : PStorage );
4302 begin
4303 exc.error := TT_Err_Debug_Opcode;
4304 end;
4305
4306 (**********************************************)
4307 (* GETINFO[] : GET INFOrmation *)
4308 (* CodeRange : $88 *)
4309
4310 procedure Ins_GETINFO( args : PStorage );
4311 var
4312 K : Int;
4313 begin
4314 K := 0;
4315
4316 if args^[0] and 1 <> 0 then K := 3;
4317 (* We return then Windows 3.1 version number *)
4318 (* for the font scaler *)
4319
4320 if false then K := K or $80;
4321 (* Has the glyph been rotated ? *)
4322 (* XXXX TO DO *)
4323
4324 if false then K := K or $100;
4325 (* Has the glyph been stretched ? *)
4326 (* XXXX TO DO *)
4327
4328 args^[0] := K;
4329 end;
4330
4331
4332 procedure Ins_UNKNOWN( args : PStorage );
4333 begin
4334 exc.error := TT_Err_Invalid_Opcode;
4335 end;
4336 {$F-}
4337
4338
4339
4340 const
4341 Instruct_Dispatch : array[0..255] of TInstruction_Function
4342 = (
4343 (* SVTCA y *) Ins_SVTCA,
4344 (* SVTCA x *) Ins_SVTCA,
4345 (* SPvTCA y *) Ins_SPVTCA,
4346 (* SPvTCA x *) Ins_SPVTCA,
4347 (* SFvTCA y *) Ins_SFVTCA,
4348 (* SFvTCA x *) Ins_SFVTCA,
4349 (* SPvTL // *) Ins_SPVTL,
4350 (* SPvTL + *) Ins_SPVTL,
4351 (* SFvTL // *) Ins_SFVTL,
4352 (* SFvTL + *) Ins_SFVTL,
4353 (* SPvFS *) Ins_SPVFS,
4354 (* SFvFS *) Ins_SFVFS,
4355 (* GPV *) Ins_GPV,
4356 (* GFV *) Ins_GFV,
4357 (* SFvTPv *) Ins_SFVTPV,
4358 (* ISECT *) Ins_ISECT,
4359
4360 (* SRP0 *) Ins_SRP0,
4361 (* SRP1 *) Ins_SRP1,
4362 (* SRP2 *) Ins_SRP2,
4363 (* SZP0 *) Ins_SZP0,
4364 (* SZP1 *) Ins_SZP1,
4365 (* SZP2 *) Ins_SZP2,
4366 (* SZPS *) Ins_SZPS,
4367 (* SLOOP *) Ins_SLOOP,
4368 (* RTG *) Ins_RTG,
4369 (* RTHG *) Ins_RTHG,
4370 (* SMD *) Ins_SMD,
4371 (* ELSE *) Ins_ELSE,
4372 (* JMPR *) Ins_JMPR,
4373 (* SCvTCi *) Ins_SCVTCI,
4374 (* SSwCi *) Ins_SSWCI,
4375 (* SSW *) Ins_SSW,
4376
4377 (* DUP *) Ins_DUP,
4378 (* POP *) Ins_POP,
4379 (* CLEAR *) Ins_CLEAR,
4380 (* SWAP *) Ins_SWAP,
4381 (* DEPTH *) Ins_DEPTH,
4382 (* CINDEX *) Ins_CINDEX,
4383 (* MINDEX *) Ins_MINDEX,
4384 (* AlignPTS *) Ins_ALIGNPTS,
4385 (* INS_$28 *) Ins_UNKNOWN,
4386 (* UTP *) Ins_UTP,
4387 (* LOOPCALL *) Ins_LOOPCALL,
4388 (* CALL *) Ins_CALL,
4389 (* FDEF *) Ins_FDEF,
4390 (* ENDF *) Ins_ENDF,
4391 (* MDAP[0] *) Ins_MDAP,
4392 (* MDAP[1] *) Ins_MDAP,
4393
4394 (* IUP[0] *) Ins_IUP,
4395 (* IUP[1] *) Ins_IUP,
4396 (* SHP[0] *) Ins_SHP,
4397 (* SHP[1] *) Ins_SHP,
4398 (* SHC[0] *) Ins_SHC,
4399 (* SHC[1] *) Ins_SHC,
4400 (* SHZ[0] *) Ins_SHZ,
4401 (* SHZ[1] *) Ins_SHZ,
4402 (* SHPIX *) Ins_SHPIX,
4403 (* IP *) Ins_IP,
4404 (* MSIRP[0] *) Ins_MSIRP,
4405 (* MSIRP[1] *) Ins_MSIRP,
4406 (* AlignRP *) Ins_ALIGNRP,
4407 (* RTDG *) Ins_RTDG,
4408 (* MIAP[0] *) Ins_MIAP,
4409 (* MIAP[1] *) Ins_MIAP,
4410
4411 (* NPushB *) Ins_NPUSHB,
4412 (* NPushW *) Ins_NPUSHW,
4413 (* WS *) Ins_WS,
4414 (* RS *) Ins_RS,
4415 (* WCvtP *) Ins_WCVTP,
4416 (* RCvt *) Ins_RCVT,
4417 (* GC[0] *) Ins_GC,
4418 (* GC[1] *) Ins_GC,
4419 (* SCFS *) Ins_SCFS,
4420 (* MD[0] *) Ins_MD,
4421 (* MD[1] *) Ins_MD,
4422 (* MPPEM *) Ins_MPPEM,
4423 (* MPS *) Ins_MPS,
4424 (* FlipON *) Ins_FLIPON,
4425 (* FlipOFF *) Ins_FLIPOFF,
4426 (* DEBUG *) Ins_DEBUG,
4427
4428 (* LT *) Ins_LT,
4429 (* LTEQ *) Ins_LTEQ,
4430 (* GT *) Ins_GT,
4431 (* GTEQ *) Ins_GTEQ,
4432 (* EQ *) Ins_EQ,
4433 (* NEQ *) Ins_NEQ,
4434 (* ODD *) Ins_ODD,
4435 (* EVEN *) Ins_EVEN,
4436 (* IF *) Ins_IF,
4437 (* EIF *) Ins_EIF,
4438 (* AND *) Ins_AND,
4439 (* OR *) Ins_OR,
4440 (* NOT *) Ins_NOT,
4441 (* DeltaP1 *) Ins_DELTAP,
4442 (* SDB *) Ins_SDB,
4443 (* SDS *) Ins_SDS,
4444
4445 (* ADD *) Ins_ADD,
4446 (* SUB *) Ins_SUB,
4447 (* DIV *) Ins_DIV,
4448 (* MUL *) Ins_MUL,
4449 (* ABS *) Ins_ABS,
4450 (* NEG *) Ins_NEG,
4451 (* FLOOR *) Ins_FLOOR,
4452 (* CEILING *) Ins_CEILING,
4453 (* ROUND[0] *) Ins_ROUND,
4454 (* ROUND[1] *) Ins_ROUND,
4455 (* ROUND[2] *) Ins_ROUND,
4456 (* ROUND[3] *) Ins_ROUND,
4457 (* NROUND[0]*) Ins_ROUND,
4458 (* NROUND[1]*) Ins_ROUND,
4459 (* NROUND[2]*) Ins_ROUND,
4460 (* NROUND[3]*) Ins_ROUND,
4461
4462 (* WCvtF *) Ins_WCVTF,
4463 (* DeltaP2 *) Ins_DELTAP,
4464 (* DeltaP3 *) Ins_DELTAP,
4465 (* DeltaCn[0]*) Ins_DELTAC,
4466 (* DeltaCn[1]*) Ins_DELTAC,
4467 (* DeltaCn[2]*) Ins_DELTAC,
4468 (* SROUND *) Ins_SROUND,
4469 (* S45Round *) Ins_S45ROUND,
4470 (* JROT *) Ins_JROT,
4471 (* JROF *) Ins_JROF,
4472 (* ROFF *) Ins_ROFF,
4473 (* INS_$7B *) Ins_UNKNOWN,
4474 (* RUTG *) Ins_RUTG,
4475 (* RDTG *) Ins_RDTG,
4476 (* SANGW *) Ins_SANGW,
4477 (* AA *) Ins_AA,
4478
4479 (* FlipPT *) Ins_FLIPPT,
4480 (* FlipRgON *) Ins_FLIPRGON,
4481 (* FlipRgOFF*) Ins_FLIPRGOFF,
4482 (* INS_$83 *) Ins_UNKNOWN,
4483 (* INS_$84 *) Ins_UNKNOWN,
4484 (* ScanCTRL *) Ins_SCANCTRL,
4485 (* SDPVTL[0]*) Ins_SDPVTL,
4486 (* SDPVTL[1]*) Ins_SDPVTL,
4487 (* GetINFO *) Ins_GETINFO,
4488 (* IDEF *) Ins_IDEF,
4489 (* ROLL *) Ins_ROLL,
4490 (* MAX *) Ins_MAX,
4491 (* MIN *) Ins_MIN,
4492 (* ScanTYPE *) Ins_SCANTYPE,
4493 (* InstCTRL *) Ins_INSTCTRL,
4494 (* INS_$8F *) Ins_UNKNOWN,
4495
4496 (* INS_$90 *) Ins_UNKNOWN,
4497 (* INS_$91 *) Ins_UNKNOWN,
4498 (* INS_$92 *) Ins_UNKNOWN,
4499 (* INS_$93 *) Ins_UNKNOWN,
4500 (* INS_$94 *) Ins_UNKNOWN,
4501 (* INS_$95 *) Ins_UNKNOWN,
4502 (* INS_$96 *) Ins_UNKNOWN,
4503 (* INS_$97 *) Ins_UNKNOWN,
4504 (* INS_$98 *) Ins_UNKNOWN,
4505 (* INS_$99 *) Ins_UNKNOWN,
4506 (* INS_$9A *) Ins_UNKNOWN,
4507 (* INS_$9B *) Ins_UNKNOWN,
4508 (* INS_$9C *) Ins_UNKNOWN,
4509 (* INS_$9D *) Ins_UNKNOWN,
4510 (* INS_$9E *) Ins_UNKNOWN,
4511 (* INS_$9F *) Ins_UNKNOWN,
4512
4513 (* INS_$A0 *) Ins_UNKNOWN,
4514 (* INS_$A1 *) Ins_UNKNOWN,
4515 (* INS_$A2 *) Ins_UNKNOWN,
4516 (* INS_$A3 *) Ins_UNKNOWN,
4517 (* INS_$A4 *) Ins_UNKNOWN,
4518 (* INS_$A5 *) Ins_UNKNOWN,
4519 (* INS_$A6 *) Ins_UNKNOWN,
4520 (* INS_$A7 *) Ins_UNKNOWN,
4521 (* INS_$A8 *) Ins_UNKNOWN,
4522 (* INS_$A9 *) Ins_UNKNOWN,
4523 (* INS_$AA *) Ins_UNKNOWN,
4524 (* INS_$AB *) Ins_UNKNOWN,
4525 (* INS_$AC *) Ins_UNKNOWN,
4526 (* INS_$AD *) Ins_UNKNOWN,
4527 (* INS_$AE *) Ins_UNKNOWN,
4528 (* INS_$AF *) Ins_UNKNOWN,
4529
4530 (* PushB[0] *) Ins_PUSHB,
4531 (* PushB[1] *) Ins_PUSHB,
4532 (* PushB[2] *) Ins_PUSHB,
4533 (* PushB[3] *) Ins_PUSHB,
4534 (* PushB[4] *) Ins_PUSHB,
4535 (* PushB[5] *) Ins_PUSHB,
4536 (* PushB[6] *) Ins_PUSHB,
4537 (* PushB[7] *) Ins_PUSHB,
4538 (* PushW[0] *) Ins_PUSHW,
4539 (* PushW[1] *) Ins_PUSHW,
4540 (* PushW[2] *) Ins_PUSHW,
4541 (* PushW[3] *) Ins_PUSHW,
4542 (* PushW[4] *) Ins_PUSHW,
4543 (* PushW[5] *) Ins_PUSHW,
4544 (* PushW[6] *) Ins_PUSHW,
4545 (* PushW[7] *) Ins_PUSHW,
4546
4547 (* MDRP[00] *) Ins_MDRP,
4548 (* MDRP[01] *) Ins_MDRP,
4549 (* MDRP[02] *) Ins_MDRP,
4550 (* MDRP[03] *) Ins_MDRP,
4551 (* MDRP[04] *) Ins_MDRP,
4552 (* MDRP[05] *) Ins_MDRP,
4553 (* MDRP[06] *) Ins_MDRP,
4554 (* MDRP[07] *) Ins_MDRP,
4555 (* MDRP[08] *) Ins_MDRP,
4556 (* MDRP[09] *) Ins_MDRP,
4557 (* MDRP[10] *) Ins_MDRP,
4558 (* MDRP[11] *) Ins_MDRP,
4559 (* MDRP[12] *) Ins_MDRP,
4560 (* MDRP[13] *) Ins_MDRP,
4561 (* MDRP[14] *) Ins_MDRP,
4562 (* MDRP[15] *) Ins_MDRP,
4563 (* MDRP[16] *) Ins_MDRP,
4564 (* MDRP[17] *) Ins_MDRP,
4565
4566 (* MDRP[18] *) Ins_MDRP,
4567 (* MDRP[19] *) Ins_MDRP,
4568 (* MDRP[20] *) Ins_MDRP,
4569 (* MDRP[21] *) Ins_MDRP,
4570 (* MDRP[22] *) Ins_MDRP,
4571 (* MDRP[23] *) Ins_MDRP,
4572 (* MDRP[24] *) Ins_MDRP,
4573 (* MDRP[25] *) Ins_MDRP,
4574 (* MDRP[26] *) Ins_MDRP,
4575 (* MDRP[27] *) Ins_MDRP,
4576 (* MDRP[28] *) Ins_MDRP,
4577 (* MDRP[29] *) Ins_MDRP,
4578 (* MDRP[30] *) Ins_MDRP,
4579 (* MDRP[31] *) Ins_MDRP,
4580
4581 (* MIRP[00] *) Ins_MIRP,
4582 (* MIRP[01] *) Ins_MIRP,
4583 (* MIRP[02] *) Ins_MIRP,
4584 (* MIRP[03] *) Ins_MIRP,
4585 (* MIRP[04] *) Ins_MIRP,
4586 (* MIRP[05] *) Ins_MIRP,
4587 (* MIRP[06] *) Ins_MIRP,
4588 (* MIRP[07] *) Ins_MIRP,
4589 (* MIRP[08] *) Ins_MIRP,
4590 (* MIRP[09] *) Ins_MIRP,
4591 (* MIRP[10] *) Ins_MIRP,
4592 (* MIRP[11] *) Ins_MIRP,
4593 (* MIRP[12] *) Ins_MIRP,
4594 (* MIRP[13] *) Ins_MIRP,
4595 (* MIRP[14] *) Ins_MIRP,
4596 (* MIRP[15] *) Ins_MIRP,
4597
4598 (* MIRP[16] *) Ins_MIRP,
4599 (* MIRP[17] *) Ins_MIRP,
4600 (* MIRP[18] *) Ins_MIRP,
4601 (* MIRP[19] *) Ins_MIRP,
4602 (* MIRP[20] *) Ins_MIRP,
4603 (* MIRP[21] *) Ins_MIRP,
4604 (* MIRP[22] *) Ins_MIRP,
4605 (* MIRP[23] *) Ins_MIRP,
4606 (* MIRP[24] *) Ins_MIRP,
4607 (* MIRP[25] *) Ins_MIRP,
4608 (* MIRP[26] *) Ins_MIRP,
4609 (* MIRP[27] *) Ins_MIRP,
4610 (* MIRP[28] *) Ins_MIRP,
4611 (* MIRP[29] *) Ins_MIRP,
4612 (* MIRP[30] *) Ins_MIRP,
4613 (* MIRP[31] *) Ins_MIRP
4614
4615 );
4616
4617 (****************************************************************)
4618 (* *)
4619 (* RUN *)
4620 (* *)
4621 (* This function executes a run of opcodes. It will exit *)
4622 (* in the following cases : *)
4623 (* *)
4624 (* - Errors ( in which case it returns FALSE ) *)
4625 (* *)
4626 (* - Reaching the end of the main code range (returns TRUE) *)
4627 (* reaching the end of a code range within a function *)
4628 (* call is an error. *)
4629 (* *)
4630 (* - After executing one single opcode, if the flag *)
4631 (* 'Instruction_Trap' is set to TRUE. (returns TRUE) *)
4632 (* *)
4633 (* On exit whith TRUE, test IP < CodeSize to know wether it *)
4634 (* comes from a instruction trap or a normal termination *)
4635 (* *)
4636 (* *)
4637 (* Note : The documented DEBUG opcode pops a value from *)
4638 (* the stack. This behaviour is unsupported, here *)
4639 (* a DEBUG opcode is always an error. *)
4640 (* *)
4641 (* *)
4642 (* THIS IS THE INTERPRETER'S MAIN LOOP *)
4643 (* *)
4644 (* Instructions appear in the specs' order *)
4645 (* *)
4646 (****************************************************************)
4647
4648 function Run_Ins( exec : PExec_Context ) : Boolean;
4649 label
4650 SuiteLabel, ErrorLabel, No_Error;
4651 var
4652 A : Int;
4653 begin
4654
4655 exc := exec^;
4656
4657 (* set cvt functions *)
4658
4659 exc.metrics.ratio := 0;
4660 if exc.instance^.metrics.x_ppem <> exc.instance^.metrics.y_ppem then
4661 {$IFDEF FPK}
4662 begin
4663 exc.func_read_cvt := @Read_CVT_Stretched;
4664 exc.func_write_cvt := @Write_CVT_Stretched;
4665 exc.func_move_cvt := @Move_CVT_Stretched;
4666 end
4667 else
4668 begin
4669 exc.func_read_cvt := @Read_CVT;
4670 exc.func_write_cvt := @Write_CVT;
4671 exc.func_move_cvt := @Move_CVT;
4672 end;
4673 {$ELSE}
4674 begin
4675 exc.func_read_cvt := Read_CVT_Stretched;
4676 exc.func_write_cvt := Write_CVT_Stretched;
4677 exc.func_move_cvt := Move_CVT_Stretched;
4678 end
4679 else
4680 begin
4681 exc.func_read_cvt := Read_CVT;
4682 exc.func_write_cvt := Write_CVT;
4683 exc.func_move_cvt := Move_CVT;
4684 end;
4685 {$ENDIF}
4686 Compute_Funcs;
4687 Compute_Round( exc.GS.round_state );
4688
4689 repeat
4690 Calc_Length;
4691
4692 (* First, let's check for empty stack and overflow *)
4693
4694 exc.args := exc.top - Pop_Push_Count[ exc.opcode*2 ];
4695
4696 (* args is the top of the stack once arguments have been popped *)
4697 (* one can also see it as the index of the last argument *)
4698
4699 if exc.args < 0 then
4700 begin
4701 exc.error := TT_Err_Too_Few_Arguments;
4702 goto ErrorLabel;
4703 end;
4704
4705 exc.new_top := exc.args + Pop_Push_Count[ exc.opcode*2+1 ];
4706
4707 (* new_top is the new top of the stack, after the instruction's *)
4708 (* execution. top will be set to new_top after the 'case' *)
4709
4710 if exc.new_top > exc.stackSize then
4711 begin
4712 exc.error := TT_Err_Stack_Overflow;
4713 goto ErrorLabel;
4714 end;
4715
4716 exc.step_ins := true;
4717 exc.error := TT_Err_Ok;
4718
4719 Instruct_Dispatch[ exc.opcode ]( PStorage(@exc.stack^[exc.args]) );
4720
4721 if exc.error <> TT_Err_Ok then
4722 begin
4723
4724 case exc.error of
4725
4726 TT_Err_Invalid_Opcode: (* looking for redefined instructions *)
4727
4728 begin
4729 A := 0;
4730 while ( A < exc.numIDefs ) do
4731 with exc.IDefs^[A] do
4732
4733 if Active and ( exc.opcode = Opc ) then
4734 begin
4735 if exc.callTop >= exc.callSize then
4736 begin
4737 exc.error := TT_Err_Invalid_Reference;
4738 goto ErrorLabel;
4739 end;
4740
4741 with exc.callstack^[exc.callTop] do
4742 begin
4743 Caller_Range := exc.curRange;
4744 Caller_IP := exc.IP+1;
4745 Cur_Count := 1;
4746 Cur_Restart := Start;
4747 end;
4748
4749 if not Goto_CodeRange( Range, Start ) then
4750 goto ErrorLabel;
4751
4752 goto SuiteLabel;
4753 end
4754 else
4755 inc(A);
4756
4757 exc.error := TT_Err_Invalid_Opcode;
4758 goto ErrorLabel;
4759
4760 end;
4761 else
4762 exc.error := exc.error;
4763 goto ErrorLabel;
4764 end;
4765
4766 end;
4767
4768 exc.top := exc.new_top;
4769
4770 if exc.step_ins then inc( exc.IP, exc.length );
4771
4772 SuiteLabel:
4773
4774 if (exc.IP >= exc.codeSize) then
4775
4776 if exc.callTop > 0 then
4777 begin
4778 exc.error := TT_Err_Code_Overflow;
4779 goto ErrorLabel;
4780 end
4781 else
4782 goto No_Error;
4783
4784 until exc.instruction_trap;
4785
4786 No_Error:
4787 Run_Ins := Success;
4788 exec^ := exc;
4789 exit;
4790
4791 ErrorLabel:
4792 Run_Ins := Failure;
4793 exec^ := exc;
4794
4795 end;
4796
4797 end.
Mirror of AROS' Contrib svn.