1 /* CCL (Code Conversion Language) interpreter.
2 Copyright (C) 2001-2021 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008, 2009, 2010, 2011
5 National Institute of Advanced Industrial Science and Technology (AIST)
6 Registration Number H14PRO021
7 Copyright (C) 2003
8 National Institute of Advanced Industrial Science and Technology (AIST)
9 Registration Number H13PRO009
10
11 This file is part of GNU Emacs.
12
13 GNU Emacs is free software: you can redistribute it and/or modify
14 it under the terms of the GNU General Public License as published by
15 the Free Software Foundation, either version 3 of the License, or (at
16 your option) any later version.
17
18 GNU Emacs is distributed in the hope that it will be useful,
19 but WITHOUT ANY WARRANTY; without even the implied warranty of
20 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 GNU General Public License for more details.
22
23 You should have received a copy of the GNU General Public License
24 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
25
26 #include <config.h>
27
28 #include <stdio.h>
29 #include <limits.h>
30
31 #include "lisp.h"
32 #include "character.h"
33 #include "charset.h"
34 #include "ccl.h"
35 #include "coding.h"
36
37 /* Table of registered CCL programs. Each element is a vector of
38 NAME, CCL_PROG, RESOLVEDP, and UPDATEDP, where NAME (symbol) is the
39 name of the program, CCL_PROG (vector) is the compiled code of the
40 program, RESOLVEDP (t or nil) is the flag to tell if symbols in
41 CCL_PROG is already resolved to index numbers or not, UPDATEDP (t
42 or nil) is the flat to tell if the CCL program is updated after it
43 was once used. */
44 static Lisp_Object Vccl_program_table;
45
46 /* Return a hash table of id number ID. */
47 #define GET_HASH_TABLE(id) \
48 (XHASH_TABLE (XCDR (AREF (Vtranslation_hash_table_vector, (id)))))
49
50 /* CCL (Code Conversion Language) is a simple language which has
51 operations on one input buffer, one output buffer, and 7 registers.
52 The syntax of CCL is described in `ccl.el'. Emacs Lisp function
53 `ccl-compile' compiles a CCL program and produces a CCL code which
54 is a vector of integers. The structure of this vector is as
55 follows: The 1st element: buffer-magnification, a factor for the
56 size of output buffer compared with the size of input buffer. The
57 2nd element: address of CCL code to be executed when encountered
58 with end of input stream. The 3rd and the remaining elements: CCL
59 codes. */
60
61 /* Header of CCL compiled code */
62 #define CCL_HEADER_BUF_MAG 0
63 #define CCL_HEADER_EOF 1
64 #define CCL_HEADER_MAIN 2
65
66 /* CCL code is a sequence of 28-bit integers. Each contains a CCL
67 command and/or arguments in the following format:
68
69 |----------------- integer (28-bit) ------------------|
70 |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
71 |--constant argument--|-register-|-register-|-command-|
72 ccccccccccccccccc RRR rrr XXXXX
73 or
74 |------- relative address -------|-register-|-command-|
75 cccccccccccccccccccc rrr XXXXX
76 or
77 |------------- constant or other args ----------------|
78 cccccccccccccccccccccccccccc
79
80 where `cc...c' is a 17-bit, 20-bit, or 28-bit integer indicating a
81 constant value or a relative/absolute jump address, `RRR'
82 and `rrr' are CCL register number, `XXXXX' is one of the following
83 CCL commands. */
84
85 #define CCL_CODE_MAX ((1 << (28 - 1)) - 1)
86 #define CCL_CODE_MIN (-1 - CCL_CODE_MAX)
87
88 /* CCL commands
89
90 Each comment fields shows one or more lines for command syntax and
91 the following lines for semantics of the command. In semantics, IC
92 stands for Instruction Counter. */
93
94 #define CCL_SetRegister 0x00 /* Set register a register value:
95 1:00000000000000000RRRrrrXXXXX
96 ------------------------------
97 reg[rrr] = reg[RRR];
98 */
99
100 #define CCL_SetShortConst 0x01 /* Set register a short constant value:
101 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
102 ------------------------------
103 reg[rrr] = CCCCCCCCCCCCCCCCCCC;
104 */
105
106 #define CCL_SetConst 0x02 /* Set register a constant value:
107 1:00000000000000000000rrrXXXXX
108 2:CONSTANT
109 ------------------------------
110 reg[rrr] = CONSTANT;
111 IC++;
112 */
113
114 #define CCL_SetArray 0x03 /* Set register an element of array:
115 1:CCCCCCCCCCCCCCCCCRRRrrrXXXXX
116 2:ELEMENT[0]
117 3:ELEMENT[1]
118 ...
119 ------------------------------
120 if (0 <= reg[RRR] < CC..C)
121 reg[rrr] = ELEMENT[reg[RRR]];
122 IC += CC..C;
123 */
124
125 #define CCL_Jump 0x04 /* Jump:
126 1:A--D--D--R--E--S--S-000XXXXX
127 ------------------------------
128 IC += ADDRESS;
129 */
130
131 /* Note: If CC..C is greater than 0, the second code is omitted. */
132
133 #define CCL_JumpCond 0x05 /* Jump conditional:
134 1:A--D--D--R--E--S--S-rrrXXXXX
135 ------------------------------
136 if (!reg[rrr])
137 IC += ADDRESS;
138 */
139
140
141 #define CCL_WriteRegisterJump 0x06 /* Write register and jump:
142 1:A--D--D--R--E--S--S-rrrXXXXX
143 ------------------------------
144 write (reg[rrr]);
145 IC += ADDRESS;
146 */
147
148 #define CCL_WriteRegisterReadJump 0x07 /* Write register, read, and jump:
149 1:A--D--D--R--E--S--S-rrrXXXXX
150 2:A--D--D--R--E--S--S-rrrYYYYY
151 -----------------------------
152 write (reg[rrr]);
153 IC++;
154 read (reg[rrr]);
155 IC += ADDRESS;
156 */
157 /* Note: If read is suspended, the resumed execution starts from the
158 second code (YYYYY == CCL_ReadJump). */
159
160 #define CCL_WriteConstJump 0x08 /* Write constant and jump:
161 1:A--D--D--R--E--S--S-000XXXXX
162 2:CONST
163 ------------------------------
164 write (CONST);
165 IC += ADDRESS;
166 */
167
168 #define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump:
169 1:A--D--D--R--E--S--S-rrrXXXXX
170 2:CONST
171 3:A--D--D--R--E--S--S-rrrYYYYY
172 -----------------------------
173 write (CONST);
174 IC += 2;
175 read (reg[rrr]);
176 IC += ADDRESS;
177 */
178 /* Note: If read is suspended, the resumed execution starts from the
179 second code (YYYYY == CCL_ReadJump). */
180
181 #define CCL_WriteStringJump 0x0A /* Write string and jump:
182 1:A--D--D--R--E--S--S-000XXXXX
183 2:LENGTH
184 3:000MSTRIN[0]STRIN[1]STRIN[2]
185 ...
186 ------------------------------
187 if (M)
188 write_multibyte_string (STRING, LENGTH);
189 else
190 write_string (STRING, LENGTH);
191 IC += ADDRESS;
192 */
193
194 #define CCL_WriteArrayReadJump 0x0B /* Write an array element, read, and jump:
195 1:A--D--D--R--E--S--S-rrrXXXXX
196 2:LENGTH
197 3:ELEMENT[0]
198 4:ELEMENT[1]
199 ...
200 N:A--D--D--R--E--S--S-rrrYYYYY
201 ------------------------------
202 if (0 <= reg[rrr] < LENGTH)
203 write (ELEMENT[reg[rrr]]);
204 IC += LENGTH + 2; (... pointing at N+1)
205 read (reg[rrr]);
206 IC += ADDRESS;
207 */
208 /* Note: If read is suspended, the resumed execution starts from the
209 Nth code (YYYYY == CCL_ReadJump). */
210
211 #define CCL_ReadJump 0x0C /* Read and jump:
212 1:A--D--D--R--E--S--S-rrrYYYYY
213 -----------------------------
214 read (reg[rrr]);
215 IC += ADDRESS;
216 */
217
218 #define CCL_Branch 0x0D /* Jump by branch table:
219 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
220 2:A--D--D--R--E-S-S[0]000XXXXX
221 3:A--D--D--R--E-S-S[1]000XXXXX
222 ...
223 ------------------------------
224 if (0 <= reg[rrr] < CC..C)
225 IC += ADDRESS[reg[rrr]];
226 else
227 IC += ADDRESS[CC..C];
228 */
229
230 #define CCL_ReadRegister 0x0E /* Read bytes into registers:
231 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
232 2:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
233 ...
234 ------------------------------
235 while (CCC--)
236 read (reg[rrr]);
237 */
238
239 #define CCL_WriteExprConst 0x0F /* write result of expression:
240 1:00000OPERATION000RRR000XXXXX
241 2:CONSTANT
242 ------------------------------
243 write (reg[RRR] OPERATION CONSTANT);
244 IC++;
245 */
246
247 /* Note: If the Nth read is suspended, the resumed execution starts
248 from the Nth code. */
249
250 #define CCL_ReadBranch 0x10 /* Read one byte into a register,
251 and jump by branch table:
252 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
253 2:A--D--D--R--E-S-S[0]000XXXXX
254 3:A--D--D--R--E-S-S[1]000XXXXX
255 ...
256 ------------------------------
257 read (read[rrr]);
258 if (0 <= reg[rrr] < CC..C)
259 IC += ADDRESS[reg[rrr]];
260 else
261 IC += ADDRESS[CC..C];
262 */
263
264 #define CCL_WriteRegister 0x11 /* Write registers:
265 1:CCCCCCCCCCCCCCCCCCCrrrXXXXX
266 2:CCCCCCCCCCCCCCCCCCCrrrXXXXX
267 ...
268 ------------------------------
269 while (CCC--)
270 write (reg[rrr]);
271 ...
272 */
273
274 /* Note: If the Nth write is suspended, the resumed execution
275 starts from the Nth code. */
276
277 #define CCL_WriteExprRegister 0x12 /* Write result of expression
278 1:00000OPERATIONRrrRRR000XXXXX
279 ------------------------------
280 write (reg[RRR] OPERATION reg[Rrr]);
281 */
282
283 #define CCL_Call 0x13 /* Call the CCL program whose ID is
284 CC..C or cc..c.
285 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX
286 [2:00000000cccccccccccccccccccc]
287 ------------------------------
288 if (FFF)
289 call (cc..c)
290 IC++;
291 else
292 call (CC..C)
293 */
294
295 #define CCL_WriteConstString 0x14 /* Write a constant or a string:
296 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
297 [2:000MSTRIN[0]STRIN[1]STRIN[2]]
298 [...]
299 -----------------------------
300 if (!rrr)
301 write (CC..C)
302 else
303 if (M)
304 write_multibyte_string (STRING, CC..C);
305 else
306 write_string (STRING, CC..C);
307 IC += (CC..C + 2) / 3;
308 */
309
310 #define CCL_WriteArray 0x15 /* Write an element of array:
311 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
312 2:ELEMENT[0]
313 3:ELEMENT[1]
314 ...
315 ------------------------------
316 if (0 <= reg[rrr] < CC..C)
317 write (ELEMENT[reg[rrr]]);
318 IC += CC..C;
319 */
320
321 #define CCL_End 0x16 /* Terminate:
322 1:00000000000000000000000XXXXX
323 ------------------------------
324 terminate ();
325 */
326
327 /* The following two codes execute an assignment arithmetic/logical
328 operation. The form of the operation is like REG OP= OPERAND. */
329
330 #define CCL_ExprSelfConst 0x17 /* REG OP= constant:
331 1:00000OPERATION000000rrrXXXXX
332 2:CONSTANT
333 ------------------------------
334 reg[rrr] OPERATION= CONSTANT;
335 */
336
337 #define CCL_ExprSelfReg 0x18 /* REG1 OP= REG2:
338 1:00000OPERATION000RRRrrrXXXXX
339 ------------------------------
340 reg[rrr] OPERATION= reg[RRR];
341 */
342
343 /* The following codes execute an arithmetic/logical operation. The
344 form of the operation is like REG_X = REG_Y OP OPERAND2. */
345
346 #define CCL_SetExprConst 0x19 /* REG_X = REG_Y OP constant:
347 1:00000OPERATION000RRRrrrXXXXX
348 2:CONSTANT
349 ------------------------------
350 reg[rrr] = reg[RRR] OPERATION CONSTANT;
351 IC++;
352 */
353
354 #define CCL_SetExprReg 0x1A /* REG1 = REG2 OP REG3:
355 1:00000OPERATIONRrrRRRrrrXXXXX
356 ------------------------------
357 reg[rrr] = reg[RRR] OPERATION reg[Rrr];
358 */
359
360 #define CCL_JumpCondExprConst 0x1B /* Jump conditional according to
361 an operation on constant:
362 1:A--D--D--R--E--S--S-rrrXXXXX
363 2:OPERATION
364 3:CONSTANT
365 -----------------------------
366 reg[7] = reg[rrr] OPERATION CONSTANT;
367 if (!(reg[7]))
368 IC += ADDRESS;
369 else
370 IC += 2
371 */
372
373 #define CCL_JumpCondExprReg 0x1C /* Jump conditional according to
374 an operation on register:
375 1:A--D--D--R--E--S--S-rrrXXXXX
376 2:OPERATION
377 3:RRR
378 -----------------------------
379 reg[7] = reg[rrr] OPERATION reg[RRR];
380 if (!reg[7])
381 IC += ADDRESS;
382 else
383 IC += 2;
384 */
385
386 #define CCL_ReadJumpCondExprConst 0x1D /* Read and jump conditional according
387 to an operation on constant:
388 1:A--D--D--R--E--S--S-rrrXXXXX
389 2:OPERATION
390 3:CONSTANT
391 -----------------------------
392 read (reg[rrr]);
393 reg[7] = reg[rrr] OPERATION CONSTANT;
394 if (!reg[7])
395 IC += ADDRESS;
396 else
397 IC += 2;
398 */
399
400 #define CCL_ReadJumpCondExprReg 0x1E /* Read and jump conditional according
401 to an operation on register:
402 1:A--D--D--R--E--S--S-rrrXXXXX
403 2:OPERATION
404 3:RRR
405 -----------------------------
406 read (reg[rrr]);
407 reg[7] = reg[rrr] OPERATION reg[RRR];
408 if (!reg[7])
409 IC += ADDRESS;
410 else
411 IC += 2;
412 */
413
414 #define CCL_Extension 0x1F /* Extended CCL code
415 1:ExtendedCOMMNDRrrRRRrrrXXXXX
416 2:ARGUMENT
417 3:...
418 ------------------------------
419 extended_command (rrr,RRR,Rrr,ARGS)
420 */
421
422 /*
423 Here after, Extended CCL Instructions.
424 Bit length of extended command is 14.
425 Therefore, the instruction code range is 0..16384(0x3fff).
426 */
427
428 /* Read a multibyte character.
429 A code point is stored into reg[rrr]. A charset ID is stored into
430 reg[RRR]. */
431
432 #define CCL_ReadMultibyteChar2 0x00 /* Read Multibyte Character
433 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
434
435 /* Write a multibyte character.
436 Write a character whose code point is reg[rrr] and the charset ID
437 is reg[RRR]. */
438
439 #define CCL_WriteMultibyteChar2 0x01 /* Write Multibyte Character
440 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
441
442 /* Translate a character whose code point is reg[rrr] and the charset
443 ID is reg[RRR] by a translation table whose ID is reg[Rrr].
444
445 A translated character is set in reg[rrr] (code point) and reg[RRR]
446 (charset ID). */
447
448 #define CCL_TranslateCharacter 0x02 /* Translate a multibyte character
449 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
450
451 /* Translate a character whose code point is reg[rrr] and the charset
452 ID is reg[RRR] by a translation table whose ID is ARGUMENT.
453
454 A translated character is set in reg[rrr] (code point) and reg[RRR]
455 (charset ID). */
456
457 #define CCL_TranslateCharacterConstTbl 0x03 /* Translate a multibyte character
458 1:ExtendedCOMMNDRrrRRRrrrXXXXX
459 2:ARGUMENT(Translation Table ID)
460 */
461
462 /* Iterate looking up MAPs for reg[rrr] starting from the Nth (N =
463 reg[RRR]) MAP until some value is found.
464
465 Each MAP is a Lisp vector whose element is number, nil, t, or
466 lambda.
467 If the element is nil, ignore the map and proceed to the next map.
468 If the element is t or lambda, finish without changing reg[rrr].
469 If the element is a number, set reg[rrr] to the number and finish.
470
471 Detail of the map structure is described in the comment for
472 CCL_MapMultiple below. */
473
474 #define CCL_IterateMultipleMap 0x10 /* Iterate multiple maps
475 1:ExtendedCOMMNDXXXRRRrrrXXXXX
476 2:NUMBER of MAPs
477 3:MAP-ID1
478 4:MAP-ID2
479 ...
480 */
481
482 /* Map the code in reg[rrr] by MAPs starting from the Nth (N =
483 reg[RRR]) map.
484
485 MAPs are supplied in the succeeding CCL codes as follows:
486
487 When CCL program gives this nested structure of map to this command:
488 ((MAP-ID11
489 MAP-ID12
490 (MAP-ID121 MAP-ID122 MAP-ID123)
491 MAP-ID13)
492 (MAP-ID21
493 (MAP-ID211 (MAP-ID2111) MAP-ID212)
494 MAP-ID22)),
495 the compiled CCL codes has this sequence:
496 CCL_MapMultiple (CCL code of this command)
497 16 (total number of MAPs and SEPARATORs)
498 -7 (1st SEPARATOR)
499 MAP-ID11
500 MAP-ID12
501 -3 (2nd SEPARATOR)
502 MAP-ID121
503 MAP-ID122
504 MAP-ID123
505 MAP-ID13
506 -7 (3rd SEPARATOR)
507 MAP-ID21
508 -4 (4th SEPARATOR)
509 MAP-ID211
510 -1 (5th SEPARATOR)
511 MAP_ID2111
512 MAP-ID212
513 MAP-ID22
514
515 A value of each SEPARATOR follows this rule:
516 MAP-SET := SEPARATOR [(MAP-ID | MAP-SET)]+
517 SEPARATOR := -(number of MAP-IDs and SEPARATORs in the MAP-SET)
518
519 (*)....Nest level of MAP-SET must not be over than MAX_MAP_SET_LEVEL.
520
521 When some map fails to map (i.e. it doesn't have a value for
522 reg[rrr]), the mapping is treated as identity.
523
524 The mapping is iterated for all maps in each map set (set of maps
525 separated by SEPARATOR) except in the case that lambda is
526 encountered. More precisely, the mapping proceeds as below:
527
528 At first, VAL0 is set to reg[rrr], and it is translated by the
529 first map to VAL1. Then, VAL1 is translated by the next map to
530 VAL2. This mapping is iterated until the last map is used. The
531 result of the mapping is the last value of VAL?. When the mapping
532 process reached to the end of the map set, it moves to the next
533 map set. If the next does not exit, the mapping process terminates,
534 and regard the last value as a result.
535
536 But, when VALm is mapped to VALn and VALn is not a number, the
537 mapping proceed as below:
538
539 If VALn is nil, the last map is ignored and the mapping of VALm
540 proceed to the next map.
541
542 In VALn is t, VALm is reverted to reg[rrr] and the mapping of VALm
543 proceed to the next map.
544
545 If VALn is lambda, move to the next map set like reaching to the
546 end of the current map set.
547
548 If VALn is a symbol, call the CCL program referred by it.
549 Then, use reg[rrr] as a mapped value except for -1, -2 and -3.
550 Such special values are regarded as nil, t, and lambda respectively.
551
552 Each map is a Lisp vector of the following format (a) or (b):
553 (a)......[STARTPOINT VAL1 VAL2 ...]
554 (b)......[t VAL STARTPOINT ENDPOINT],
555 where
556 STARTPOINT is an offset to be used for indexing a map,
557 ENDPOINT is a maximum index number of a map,
558 VAL and VALn is a number, nil, t, or lambda.
559
560 Valid index range of a map of type (a) is:
561 STARTPOINT <= index < STARTPOINT + map_size - 1
562 Valid index range of a map of type (b) is:
563 STARTPOINT <= index < ENDPOINT */
564
565 #define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
566 1:ExtendedCOMMNDXXXRRRrrrXXXXX
567 2:N-2
568 3:SEPARATOR_1 (< 0)
569 4:MAP-ID_1
570 5:MAP-ID_2
571 ...
572 M:SEPARATOR_x (< 0)
573 M+1:MAP-ID_y
574 ...
575 N:SEPARATOR_z (< 0)
576 */
577
578 #define MAX_MAP_SET_LEVEL 30
579
580 typedef struct
581 {
582 int rest_length;
583 int orig_val;
584 } tr_stack;
585
586 static tr_stack mapping_stack[MAX_MAP_SET_LEVEL];
587 static tr_stack *mapping_stack_pointer;
588
589 /* If this variable is non-zero, it indicates the stack_idx
590 of immediately called by CCL_MapMultiple. */
591 static int stack_idx_of_map_multiple;
592
593 #define PUSH_MAPPING_STACK(restlen, orig) \
594 do \
595 { \
596 mapping_stack_pointer->rest_length = (restlen); \
597 mapping_stack_pointer->orig_val = (orig); \
598 mapping_stack_pointer++; \
599 } \
600 while (0)
601
602 #define POP_MAPPING_STACK(restlen, orig) \
603 do \
604 { \
605 mapping_stack_pointer--; \
606 (restlen) = mapping_stack_pointer->rest_length; \
607 (orig) = mapping_stack_pointer->orig_val; \
608 } \
609 while (0)
610
611 #define CCL_CALL_FOR_MAP_INSTRUCTION(symbol, ret_ic) \
612 do \
613 { \
614 struct ccl_program called_ccl; \
615 if (stack_idx >= 256 \
616 || ! setup_ccl_program (&called_ccl, (symbol))) \
617 { \
618 if (stack_idx > 0) \
619 { \
620 ccl_prog = ccl_prog_stack_struct[0].ccl_prog; \
621 ic = ccl_prog_stack_struct[0].ic; \
622 eof_ic = ccl_prog_stack_struct[0].eof_ic; \
623 } \
624 CCL_INVALID_CMD; \
625 } \
626 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; \
627 ccl_prog_stack_struct[stack_idx].ic = (ret_ic); \
628 ccl_prog_stack_struct[stack_idx].eof_ic = eof_ic; \
629 stack_idx++; \
630 ccl_prog = called_ccl.prog; \
631 ic = CCL_HEADER_MAIN; \
632 eof_ic = XFIXNAT (ccl_prog[CCL_HEADER_EOF]); \
633 goto ccl_repeat; \
634 } \
635 while (0)
636
637 #define CCL_MapSingle 0x12 /* Map by single code conversion map
638 1:ExtendedCOMMNDXXXRRRrrrXXXXX
639 2:MAP-ID
640 ------------------------------
641 Map reg[rrr] by MAP-ID.
642 If some valid mapping is found,
643 set reg[rrr] to the result,
644 else
645 set reg[RRR] to -1.
646 */
647
648 #define CCL_LookupIntConstTbl 0x13 /* Lookup multibyte character by
649 integer key. Afterwards R7 set
650 to 1 if lookup succeeded.
651 1:ExtendedCOMMNDRrrRRRXXXXXXXX
652 2:ARGUMENT(Hash table ID) */
653
654 #define CCL_LookupCharConstTbl 0x14 /* Lookup integer by multibyte
655 character key. Afterwards R7 set
656 to 1 if lookup succeeded.
657 1:ExtendedCOMMNDRrrRRRrrrXXXXX
658 2:ARGUMENT(Hash table ID) */
659
660 /* CCL arithmetic/logical operators. */
661 #define CCL_PLUS 0x00 /* X = Y + Z */
662 #define CCL_MINUS 0x01 /* X = Y - Z */
663 #define CCL_MUL 0x02 /* X = Y * Z */
664 #define CCL_DIV 0x03 /* X = Y / Z */
665 #define CCL_MOD 0x04 /* X = Y % Z */
666 #define CCL_AND 0x05 /* X = Y & Z */
667 #define CCL_OR 0x06 /* X = Y | Z */
668 #define CCL_XOR 0x07 /* X = Y ^ Z */
669 #define CCL_LSH 0x08 /* X = Y << Z */
670 #define CCL_RSH 0x09 /* X = Y >> Z */
671 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
672 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
673 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
674 #define CCL_LS 0x10 /* X = (X < Y) */
675 #define CCL_GT 0x11 /* X = (X > Y) */
676 #define CCL_EQ 0x12 /* X = (X == Y) */
677 #define CCL_LE 0x13 /* X = (X <= Y) */
678 #define CCL_GE 0x14 /* X = (X >= Y) */
679 #define CCL_NE 0x15 /* X = (X != Y) */
680
681 #define CCL_DECODE_SJIS 0x16 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
682 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
683 #define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z))
684 r[7] = LOWER_BYTE (SJIS (Y, Z) */
685
686 /* Terminate CCL program successfully. */
687 #define CCL_SUCCESS \
688 do \
689 { \
690 ccl->status = CCL_STAT_SUCCESS; \
691 goto ccl_finish; \
692 } \
693 while (0)
694
695 /* Suspend CCL program because of reading from empty input buffer or
696 writing to full output buffer. When this program is resumed, the
697 same I/O command is executed. */
698 #define CCL_SUSPEND(stat) \
699 do \
700 { \
701 ic--; \
702 ccl->status = stat; \
703 goto ccl_finish; \
704 } \
705 while (0)
706
707 /* Terminate CCL program because of invalid command. Should not occur
708 in the normal case. */
709 #ifndef CCL_DEBUG
710
711 #define CCL_INVALID_CMD \
712 do \
713 { \
714 ccl->status = CCL_STAT_INVALID_CMD; \
715 goto ccl_error_handler; \
716 } \
717 while (0)
718
719 #else
720
721 #define CCL_INVALID_CMD \
722 do \
723 { \
724 ccl_debug_hook (this_ic); \
725 ccl->status = CCL_STAT_INVALID_CMD; \
726 goto ccl_error_handler; \
727 } \
728 while (0)
729
730 #endif
731
732 /* Use "&" rather than "&&" to suppress a bogus GCC warning; see
733 <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=43772>. */
734 #define ASCENDING_ORDER(lo, med, hi) (((lo) <= (med)) & ((med) <= (hi)))
735
736 #define GET_CCL_RANGE(var, ccl_prog, ic, lo, hi) \
737 do \
738 { \
739 EMACS_INT prog_word = XFIXNUM ((ccl_prog)[ic]); \
740 if (! ASCENDING_ORDER (lo, prog_word, hi)) \
741 CCL_INVALID_CMD; \
742 (var) = prog_word; \
743 } \
744 while (0)
745
746 #define GET_CCL_CODE(code, ccl_prog, ic) \
747 GET_CCL_RANGE (code, ccl_prog, ic, CCL_CODE_MIN, CCL_CODE_MAX)
748
749 #define IN_INT_RANGE(val) ASCENDING_ORDER (INT_MIN, val, INT_MAX)
750
751 /* Encode one character CH to multibyte form and write to the current
752 output buffer. If CH is less than 256, CH is written as is. */
753 #define CCL_WRITE_CHAR(ch) \
754 do { \
755 if (! dst) \
756 CCL_INVALID_CMD; \
757 else if (dst < dst_end) \
758 *dst++ = (ch); \
759 else \
760 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
761 } while (0)
762
763 /* Write a string at ccl_prog[IC] of length LEN to the current output
764 buffer. */
765 #define CCL_WRITE_STRING(len) \
766 do { \
767 int ccli; \
768 if (!dst) \
769 CCL_INVALID_CMD; \
770 else if (dst + len <= dst_end) \
771 { \
772 if (XFIXNAT (ccl_prog[ic]) & 0x1000000) \
773 for (ccli = 0; ccli < len; ccli++) \
774 *dst++ = XFIXNAT (ccl_prog[ic + ccli]) & 0xFFFFFF; \
775 else \
776 for (ccli = 0; ccli < len; ccli++) \
777 *dst++ = ((XFIXNAT (ccl_prog[ic + (ccli / 3)])) \
778 >> ((2 - (ccli % 3)) * 8)) & 0xFF; \
779 } \
780 else \
781 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
782 } while (0)
783
784 /* Read one byte from the current input buffer into Rth register. */
785 #define CCL_READ_CHAR(r) \
786 do { \
787 if (! src) \
788 CCL_INVALID_CMD; \
789 else if (src < src_end) \
790 r = *src++; \
791 else if (ccl->last_block) \
792 { \
793 r = -1; \
794 ic = ccl->eof_ic; \
795 goto ccl_repeat; \
796 } \
797 else \
798 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
799 } while (0)
800
801 /* Decode CODE by a charset whose id is ID. If ID is 0, return CODE
802 as is for backward compatibility. Assume that we can use the
803 variable `charset'. */
804
805 #define CCL_DECODE_CHAR(id, code) \
806 ((id) == 0 ? (code) \
807 : (charset = CHARSET_FROM_ID ((id)), DECODE_CHAR (charset, (code))))
808
809 /* Encode character C by some of charsets in CHARSET_LIST. Set ID to
810 the id of the used charset, ENCODED to the result of encoding.
811 Assume that we can use the variable `charset'. */
812
813 #define CCL_ENCODE_CHAR(c, charset_list, id, encoded) \
814 do { \
815 unsigned ncode; \
816 \
817 charset = char_charset ((c), (charset_list), &ncode); \
818 if (! charset && ! NILP (charset_list)) \
819 charset = char_charset ((c), Qnil, &ncode); \
820 if (charset) \
821 { \
822 (id) = CHARSET_ID (charset); \
823 (encoded) = ncode; \
824 } \
825 } while (0)
826
827 /* Execute CCL code on characters at SOURCE (length SRC_SIZE). The
828 resulting text goes to a place pointed by DESTINATION, the length
829 of which should not exceed DST_SIZE. As a side effect, how many
830 characters are consumed and produced are recorded in CCL->consumed
831 and CCL->produced, and the contents of CCL registers are updated.
832 If SOURCE or DESTINATION is NULL, only operations on registers are
833 permitted. */
834
835 #ifdef CCL_DEBUG
836 #define CCL_DEBUG_BACKTRACE_LEN 256
837 int ccl_backtrace_table[CCL_DEBUG_BACKTRACE_LEN];
838 int ccl_backtrace_idx;
839
840 int
ccl_debug_hook(int ic)841 ccl_debug_hook (int ic)
842 {
843 return ic;
844 }
845
846 #endif
847
848 struct ccl_prog_stack
849 {
850 Lisp_Object *ccl_prog; /* Pointer to an array of CCL code. */
851 int ic; /* Instruction Counter. */
852 int eof_ic; /* Instruction Counter to jump on EOF. */
853 };
854
855 /* For the moment, we only support depth 256 of stack. */
856 static struct ccl_prog_stack ccl_prog_stack_struct[256];
857
858 /* Return a translation table of id number ID. */
859 static inline Lisp_Object
GET_TRANSLATION_TABLE(int id)860 GET_TRANSLATION_TABLE (int id)
861 {
862 return XCDR (XVECTOR (Vtranslation_table_vector)->contents[id]);
863 }
864
865 void
ccl_driver(struct ccl_program * ccl,int * source,int * destination,int src_size,int dst_size,Lisp_Object charset_list)866 ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size, int dst_size, Lisp_Object charset_list)
867 {
868 register int *reg = ccl->reg;
869 register int ic = ccl->ic;
870 register int code = 0, field1, field2;
871 register Lisp_Object *ccl_prog = ccl->prog;
872 int *src = source, *src_end = src + src_size;
873 int *dst = destination, *dst_end = dst + dst_size;
874 int jump_address;
875 int i = 0, j, op;
876 int stack_idx = ccl->stack_idx;
877 /* Instruction counter of the current CCL code. */
878 int this_ic = 0;
879 struct charset *charset;
880 int eof_ic = ccl->eof_ic;
881 int eof_hit = 0;
882
883 if (ccl->buf_magnification == 0) /* We can't read/produce any bytes. */
884 dst = NULL;
885
886 /* Set mapping stack pointer. */
887 mapping_stack_pointer = mapping_stack;
888
889 #ifdef CCL_DEBUG
890 ccl_backtrace_idx = 0;
891 #endif
892
893 for (;;)
894 {
895 ccl_repeat:
896 #ifdef CCL_DEBUG
897 ccl_backtrace_table[ccl_backtrace_idx++] = ic;
898 if (ccl_backtrace_idx >= CCL_DEBUG_BACKTRACE_LEN)
899 ccl_backtrace_idx = 0;
900 ccl_backtrace_table[ccl_backtrace_idx] = 0;
901 #endif
902
903 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
904 {
905 /* We can't just signal Qquit, instead break the loop as if
906 the whole data is processed. Don't reset Vquit_flag, it
907 must be handled later at a safer place. */
908 if (src)
909 src = source + src_size;
910 ccl->status = CCL_STAT_QUIT;
911 break;
912 }
913
914 this_ic = ic;
915 GET_CCL_CODE (code, ccl_prog, ic++);
916 field1 = code >> 8;
917 field2 = (code & 0xFF) >> 5;
918
919 #define rrr field2
920 #define RRR (field1 & 7)
921 #define Rrr ((field1 >> 3) & 7)
922 #define ADDR field1
923 #define EXCMD (field1 >> 6)
924
925 switch (code & 0x1F)
926 {
927 case CCL_SetRegister: /* 00000000000000000RRRrrrXXXXX */
928 reg[rrr] = reg[RRR];
929 break;
930
931 case CCL_SetShortConst: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
932 reg[rrr] = field1;
933 break;
934
935 case CCL_SetConst: /* 00000000000000000000rrrXXXXX */
936 reg[rrr] = XFIXNUM (ccl_prog[ic++]);
937 break;
938
939 case CCL_SetArray: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
940 i = reg[RRR];
941 j = field1 >> 3;
942 if (0 <= i && i < j)
943 reg[rrr] = XFIXNUM (ccl_prog[ic + i]);
944 ic += j;
945 break;
946
947 case CCL_Jump: /* A--D--D--R--E--S--S-000XXXXX */
948 ic += ADDR;
949 break;
950
951 case CCL_JumpCond: /* A--D--D--R--E--S--S-rrrXXXXX */
952 if (!reg[rrr])
953 ic += ADDR;
954 break;
955
956 case CCL_WriteRegisterJump: /* A--D--D--R--E--S--S-rrrXXXXX */
957 i = reg[rrr];
958 CCL_WRITE_CHAR (i);
959 ic += ADDR;
960 break;
961
962 case CCL_WriteRegisterReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
963 i = reg[rrr];
964 CCL_WRITE_CHAR (i);
965 ic++;
966 CCL_READ_CHAR (reg[rrr]);
967 ic += ADDR - 1;
968 break;
969
970 case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */
971 i = XFIXNUM (ccl_prog[ic]);
972 CCL_WRITE_CHAR (i);
973 ic += ADDR;
974 break;
975
976 case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
977 i = XFIXNUM (ccl_prog[ic]);
978 CCL_WRITE_CHAR (i);
979 ic++;
980 CCL_READ_CHAR (reg[rrr]);
981 ic += ADDR - 1;
982 break;
983
984 case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */
985 j = XFIXNUM (ccl_prog[ic++]);
986 CCL_WRITE_STRING (j);
987 ic += ADDR - 1;
988 break;
989
990 case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
991 i = reg[rrr];
992 j = XFIXNUM (ccl_prog[ic]);
993 if (0 <= i && i < j)
994 {
995 i = XFIXNUM (ccl_prog[ic + 1 + i]);
996 CCL_WRITE_CHAR (i);
997 }
998 ic += j + 2;
999 CCL_READ_CHAR (reg[rrr]);
1000 ic += ADDR - (j + 2);
1001 break;
1002
1003 case CCL_ReadJump: /* A--D--D--R--E--S--S-rrrYYYYY */
1004 CCL_READ_CHAR (reg[rrr]);
1005 ic += ADDR;
1006 break;
1007
1008 case CCL_ReadBranch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1009 CCL_READ_CHAR (reg[rrr]);
1010 FALLTHROUGH;
1011 case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1012 {
1013 int ioff = 0 <= reg[rrr] && reg[rrr] < field1 ? reg[rrr] : field1;
1014 int incr = XFIXNUM (ccl_prog[ic + ioff]);
1015 ic += incr;
1016 }
1017 break;
1018
1019 case CCL_ReadRegister: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
1020 while (1)
1021 {
1022 CCL_READ_CHAR (reg[rrr]);
1023 if (!field1) break;
1024 GET_CCL_CODE (code, ccl_prog, ic++);
1025 field1 = code >> 8;
1026 field2 = (code & 0xFF) >> 5;
1027 }
1028 break;
1029
1030 case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */
1031 rrr = 7;
1032 i = reg[RRR];
1033 j = XFIXNUM (ccl_prog[ic]);
1034 op = field1 >> 6;
1035 jump_address = ic + 1;
1036 goto ccl_set_expr;
1037
1038 case CCL_WriteRegister: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
1039 while (1)
1040 {
1041 i = reg[rrr];
1042 CCL_WRITE_CHAR (i);
1043 if (!field1) break;
1044 GET_CCL_CODE (code, ccl_prog, ic++);
1045 field1 = code >> 8;
1046 field2 = (code & 0xFF) >> 5;
1047 }
1048 break;
1049
1050 case CCL_WriteExprRegister: /* 1:00000OPERATIONRrrRRR000XXXXX */
1051 rrr = 7;
1052 i = reg[RRR];
1053 j = reg[Rrr];
1054 op = field1 >> 6;
1055 jump_address = ic;
1056 goto ccl_set_expr;
1057
1058 case CCL_Call: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
1059 {
1060 Lisp_Object slot;
1061 int prog_id;
1062
1063 /* If FFF is nonzero, the CCL program ID is in the
1064 following code. */
1065 if (rrr)
1066 prog_id = XFIXNUM (ccl_prog[ic++]);
1067 else
1068 prog_id = field1;
1069
1070 if (stack_idx >= 256
1071 || prog_id < 0
1072 || prog_id >= ASIZE (Vccl_program_table)
1073 || (slot = AREF (Vccl_program_table, prog_id), !VECTORP (slot))
1074 || !VECTORP (AREF (slot, 1)))
1075 {
1076 if (stack_idx > 0)
1077 {
1078 ccl_prog = ccl_prog_stack_struct[0].ccl_prog;
1079 ic = ccl_prog_stack_struct[0].ic;
1080 eof_ic = ccl_prog_stack_struct[0].eof_ic;
1081 }
1082 CCL_INVALID_CMD;
1083 }
1084
1085 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog;
1086 ccl_prog_stack_struct[stack_idx].ic = ic;
1087 ccl_prog_stack_struct[stack_idx].eof_ic = eof_ic;
1088 stack_idx++;
1089 ccl_prog = XVECTOR (AREF (slot, 1))->contents;
1090 ic = CCL_HEADER_MAIN;
1091 eof_ic = XFIXNAT (ccl_prog[CCL_HEADER_EOF]);
1092 }
1093 break;
1094
1095 case CCL_WriteConstString: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1096 if (!rrr)
1097 CCL_WRITE_CHAR (field1);
1098 else
1099 {
1100 CCL_WRITE_STRING (field1);
1101 ic += (field1 + 2) / 3;
1102 }
1103 break;
1104
1105 case CCL_WriteArray: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1106 i = reg[rrr];
1107 if (0 <= i && i < field1)
1108 {
1109 j = XFIXNUM (ccl_prog[ic + i]);
1110 CCL_WRITE_CHAR (j);
1111 }
1112 ic += field1;
1113 break;
1114
1115 case CCL_End: /* 0000000000000000000000XXXXX */
1116 if (stack_idx > 0)
1117 {
1118 stack_idx--;
1119 ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog;
1120 ic = ccl_prog_stack_struct[stack_idx].ic;
1121 eof_ic = ccl_prog_stack_struct[stack_idx].eof_ic;
1122 if (eof_hit)
1123 ic = eof_ic;
1124 break;
1125 }
1126 if (src)
1127 src = src_end;
1128 /* ccl->ic should points to this command code again to
1129 suppress further processing. */
1130 ic--;
1131 CCL_SUCCESS;
1132
1133 case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */
1134 i = XFIXNUM (ccl_prog[ic++]);
1135 op = field1 >> 6;
1136 goto ccl_expr_self;
1137
1138 case CCL_ExprSelfReg: /* 00000OPERATION000RRRrrrXXXXX */
1139 i = reg[RRR];
1140 op = field1 >> 6;
1141
1142 ccl_expr_self:
1143 switch (op)
1144 {
1145 case CCL_PLUS: INT_ADD_WRAPV (reg[rrr], i, ®[rrr]); break;
1146 case CCL_MINUS: INT_SUBTRACT_WRAPV (reg[rrr], i, ®[rrr]); break;
1147 case CCL_MUL: INT_MULTIPLY_WRAPV (reg[rrr], i, ®[rrr]); break;
1148 case CCL_DIV:
1149 if (!i)
1150 CCL_INVALID_CMD;
1151 if (!INT_DIVIDE_OVERFLOW (reg[rrr], i))
1152 reg[rrr] /= i;
1153 break;
1154 case CCL_MOD:
1155 if (!i)
1156 CCL_INVALID_CMD;
1157 reg[rrr] = i == -1 ? 0 : reg[rrr] % i;
1158 break;
1159 case CCL_AND: reg[rrr] &= i; break;
1160 case CCL_OR: reg[rrr] |= i; break;
1161 case CCL_XOR: reg[rrr] ^= i; break;
1162 case CCL_LSH:
1163 if (i < 0)
1164 CCL_INVALID_CMD;
1165 reg[rrr] = i < UINT_WIDTH ? (unsigned) reg[rrr] << i : 0;
1166 break;
1167 case CCL_RSH:
1168 if (i < 0)
1169 CCL_INVALID_CMD;
1170 reg[rrr] = reg[rrr] >> min (i, INT_WIDTH - 1);
1171 break;
1172 case CCL_LSH8:
1173 reg[rrr] = (unsigned) reg[rrr] << 8;
1174 reg[rrr] |= i;
1175 break;
1176 case CCL_RSH8: reg[7] = reg[rrr] & 0xFF; reg[rrr] >>= 8; break;
1177 case CCL_DIVMOD:
1178 if (!i)
1179 CCL_INVALID_CMD;
1180 if (i == -1)
1181 {
1182 reg[7] = 0;
1183 INT_SUBTRACT_WRAPV (0, reg[rrr], ®[rrr]);
1184 }
1185 else
1186 {
1187 reg[7] = reg[rrr] % i;
1188 reg[rrr] /= i;
1189 }
1190 break;
1191 case CCL_LS: reg[rrr] = reg[rrr] < i; break;
1192 case CCL_GT: reg[rrr] = reg[rrr] > i; break;
1193 case CCL_EQ: reg[rrr] = reg[rrr] == i; break;
1194 case CCL_LE: reg[rrr] = reg[rrr] <= i; break;
1195 case CCL_GE: reg[rrr] = reg[rrr] >= i; break;
1196 case CCL_NE: reg[rrr] = reg[rrr] != i; break;
1197 default: CCL_INVALID_CMD;
1198 }
1199 break;
1200
1201 case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */
1202 i = reg[RRR];
1203 j = XFIXNUM (ccl_prog[ic++]);
1204 op = field1 >> 6;
1205 jump_address = ic;
1206 goto ccl_set_expr;
1207
1208 case CCL_SetExprReg: /* 00000OPERATIONRrrRRRrrrXXXXX */
1209 i = reg[RRR];
1210 j = reg[Rrr];
1211 op = field1 >> 6;
1212 jump_address = ic;
1213 goto ccl_set_expr;
1214
1215 case CCL_ReadJumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1216 CCL_READ_CHAR (reg[rrr]);
1217 FALLTHROUGH;
1218 case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1219 i = reg[rrr];
1220 jump_address = ic + ADDR;
1221 op = XFIXNUM (ccl_prog[ic++]);
1222 j = XFIXNUM (ccl_prog[ic++]);
1223 rrr = 7;
1224 goto ccl_set_expr;
1225
1226 case CCL_ReadJumpCondExprReg: /* A--D--D--R--E--S--S-rrrXXXXX */
1227 CCL_READ_CHAR (reg[rrr]);
1228 FALLTHROUGH;
1229 case CCL_JumpCondExprReg:
1230 i = reg[rrr];
1231 jump_address = ic + ADDR;
1232 op = XFIXNUM (ccl_prog[ic++]);
1233 GET_CCL_RANGE (j, ccl_prog, ic++, 0, 7);
1234 j = reg[j];
1235 rrr = 7;
1236
1237 ccl_set_expr:
1238 switch (op)
1239 {
1240 case CCL_PLUS: INT_ADD_WRAPV (i, j, ®[rrr]); break;
1241 case CCL_MINUS: INT_SUBTRACT_WRAPV (i, j, ®[rrr]); break;
1242 case CCL_MUL: INT_MULTIPLY_WRAPV (i, j, ®[rrr]); break;
1243 case CCL_DIV:
1244 if (!j)
1245 CCL_INVALID_CMD;
1246 if (!INT_DIVIDE_OVERFLOW (i, j))
1247 i /= j;
1248 reg[rrr] = i;
1249 break;
1250 case CCL_MOD:
1251 if (!j)
1252 CCL_INVALID_CMD;
1253 reg[rrr] = j == -1 ? 0 : i % j;
1254 break;
1255 case CCL_AND: reg[rrr] = i & j; break;
1256 case CCL_OR: reg[rrr] = i | j; break;
1257 case CCL_XOR: reg[rrr] = i ^ j; break;
1258 case CCL_LSH:
1259 if (j < 0)
1260 CCL_INVALID_CMD;
1261 reg[rrr] = j < UINT_WIDTH ? (unsigned) i << j : 0;
1262 break;
1263 case CCL_RSH:
1264 if (j < 0)
1265 CCL_INVALID_CMD;
1266 reg[rrr] = i >> min (j, INT_WIDTH - 1);
1267 break;
1268 case CCL_LSH8:
1269 reg[rrr] = ((unsigned) i << 8) | j;
1270 break;
1271 case CCL_RSH8: reg[rrr] = i >> 8; reg[7] = i & 0xFF; break;
1272 case CCL_DIVMOD:
1273 if (!j)
1274 CCL_INVALID_CMD;
1275 if (j == -1)
1276 {
1277 INT_SUBTRACT_WRAPV (0, reg[rrr], ®[rrr]);
1278 reg[7] = 0;
1279 }
1280 else
1281 {
1282 reg[rrr] = i / j;
1283 reg[7] = i % j;
1284 }
1285 break;
1286 case CCL_LS: reg[rrr] = i < j; break;
1287 case CCL_GT: reg[rrr] = i > j; break;
1288 case CCL_EQ: reg[rrr] = i == j; break;
1289 case CCL_LE: reg[rrr] = i <= j; break;
1290 case CCL_GE: reg[rrr] = i >= j; break;
1291 case CCL_NE: reg[rrr] = i != j; break;
1292 case CCL_DECODE_SJIS:
1293 {
1294 i = ((unsigned) i << 8) | j;
1295 SJIS_TO_JIS (i);
1296 reg[rrr] = i >> 8;
1297 reg[7] = i & 0xFF;
1298 break;
1299 }
1300 case CCL_ENCODE_SJIS:
1301 {
1302 i = ((unsigned) i << 8) | j;
1303 JIS_TO_SJIS (i);
1304 reg[rrr] = i >> 8;
1305 reg[7] = i & 0xFF;
1306 break;
1307 }
1308 default: CCL_INVALID_CMD;
1309 }
1310 code &= 0x1F;
1311 if (code == CCL_WriteExprConst || code == CCL_WriteExprRegister)
1312 {
1313 i = reg[rrr];
1314 CCL_WRITE_CHAR (i);
1315 ic = jump_address;
1316 }
1317 else if (!reg[rrr])
1318 ic = jump_address;
1319 break;
1320
1321 case CCL_Extension:
1322 switch (EXCMD)
1323 {
1324 case CCL_ReadMultibyteChar2:
1325 if (!src)
1326 CCL_INVALID_CMD;
1327 CCL_READ_CHAR (i);
1328 CCL_ENCODE_CHAR (i, charset_list, reg[RRR], reg[rrr]);
1329 break;
1330
1331 case CCL_WriteMultibyteChar2:
1332 if (! dst)
1333 CCL_INVALID_CMD;
1334 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1335 CCL_WRITE_CHAR (i);
1336 break;
1337
1338 case CCL_TranslateCharacter:
1339 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1340 op = translate_char (GET_TRANSLATION_TABLE (reg[Rrr]), i);
1341 CCL_ENCODE_CHAR (op, charset_list, reg[RRR], reg[rrr]);
1342 break;
1343
1344 case CCL_TranslateCharacterConstTbl:
1345 {
1346 ptrdiff_t eop;
1347 GET_CCL_RANGE (eop, ccl_prog, ic++, 0,
1348 (VECTORP (Vtranslation_table_vector)
1349 ? ASIZE (Vtranslation_table_vector)
1350 : -1));
1351 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1352 op = translate_char (GET_TRANSLATION_TABLE (eop), i);
1353 CCL_ENCODE_CHAR (op, charset_list, reg[RRR], reg[rrr]);
1354 }
1355 break;
1356
1357 case CCL_LookupIntConstTbl:
1358 {
1359 ptrdiff_t eop;
1360 struct Lisp_Hash_Table *h;
1361 GET_CCL_RANGE (eop, ccl_prog, ic++, 0,
1362 (VECTORP (Vtranslation_hash_table_vector)
1363 ? ASIZE (Vtranslation_hash_table_vector)
1364 : -1));
1365 h = GET_HASH_TABLE (eop);
1366
1367 eop = (FIXNUM_OVERFLOW_P (reg[RRR])
1368 ? -1
1369 : hash_lookup (h, make_fixnum (reg[RRR]), NULL));
1370 if (eop >= 0)
1371 {
1372 Lisp_Object opl;
1373 opl = HASH_VALUE (h, eop);
1374 if (! (IN_INT_RANGE (eop) && CHARACTERP (opl)))
1375 CCL_INVALID_CMD;
1376 reg[RRR] = charset_unicode;
1377 reg[rrr] = XFIXNUM (opl);
1378 reg[7] = 1; /* r7 true for success */
1379 }
1380 else
1381 reg[7] = 0;
1382 }
1383 break;
1384
1385 case CCL_LookupCharConstTbl:
1386 {
1387 ptrdiff_t eop;
1388 struct Lisp_Hash_Table *h;
1389 GET_CCL_RANGE (eop, ccl_prog, ic++, 0,
1390 (VECTORP (Vtranslation_hash_table_vector)
1391 ? ASIZE (Vtranslation_hash_table_vector)
1392 : -1));
1393 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1394 h = GET_HASH_TABLE (eop);
1395
1396 eop = (FIXNUM_OVERFLOW_P (i)
1397 ? -1
1398 : hash_lookup (h, make_fixnum (i), NULL));
1399 if (eop >= 0)
1400 {
1401 Lisp_Object opl;
1402 opl = HASH_VALUE (h, eop);
1403 if (! (FIXNUMP (opl) && IN_INT_RANGE (XFIXNUM (opl))))
1404 CCL_INVALID_CMD;
1405 reg[RRR] = XFIXNUM (opl);
1406 reg[7] = 1; /* r7 true for success */
1407 }
1408 else
1409 reg[7] = 0;
1410 }
1411 break;
1412
1413 case CCL_IterateMultipleMap:
1414 {
1415 Lisp_Object map, content, attrib, value;
1416 EMACS_INT point;
1417 ptrdiff_t size;
1418 int fin_ic;
1419
1420 j = XFIXNUM (ccl_prog[ic++]); /* number of maps. */
1421 fin_ic = ic + j;
1422 op = reg[rrr];
1423 if ((j > reg[RRR]) && (j >= 0))
1424 {
1425 ic += reg[RRR];
1426 i = reg[RRR];
1427 }
1428 else
1429 {
1430 reg[RRR] = -1;
1431 ic = fin_ic;
1432 break;
1433 }
1434
1435 for (;i < j;i++)
1436 {
1437 if (!VECTORP (Vcode_conversion_map_vector)) continue;
1438 size = ASIZE (Vcode_conversion_map_vector);
1439 point = XFIXNUM (ccl_prog[ic++]);
1440 if (! (0 <= point && point < size)) continue;
1441 map = AREF (Vcode_conversion_map_vector, point);
1442
1443 /* Check map validity. */
1444 if (!CONSP (map)) continue;
1445 map = XCDR (map);
1446 if (!VECTORP (map)) continue;
1447 size = ASIZE (map);
1448 if (size <= 1) continue;
1449
1450 content = AREF (map, 0);
1451
1452 /* check map type,
1453 [STARTPOINT VAL1 VAL2 ...] or
1454 [t ELEMENT STARTPOINT ENDPOINT] */
1455 if (FIXNUMP (content))
1456 {
1457 point = XFIXNUM (content);
1458 if (!(point <= op && op - point + 1 < size)) continue;
1459 content = AREF (map, op - point + 1);
1460 }
1461 else if (EQ (content, Qt))
1462 {
1463 if (size != 4) continue;
1464 if (FIXNUMP (AREF (map, 2))
1465 && XFIXNUM (AREF (map, 2)) <= op
1466 && FIXNUMP (AREF (map, 3))
1467 && op < XFIXNUM (AREF (map, 3)))
1468 content = AREF (map, 1);
1469 else
1470 continue;
1471 }
1472 else
1473 continue;
1474
1475 if (NILP (content))
1476 continue;
1477 else if (FIXNUMP (content) && IN_INT_RANGE (XFIXNUM (content)))
1478 {
1479 reg[RRR] = i;
1480 reg[rrr] = XFIXNUM (content);
1481 break;
1482 }
1483 else if (EQ (content, Qt) || EQ (content, Qlambda))
1484 {
1485 reg[RRR] = i;
1486 break;
1487 }
1488 else if (CONSP (content))
1489 {
1490 attrib = XCAR (content);
1491 value = XCDR (content);
1492 if (! (FIXNUMP (attrib) && FIXNUMP (value)
1493 && IN_INT_RANGE (XFIXNUM (value))))
1494 continue;
1495 reg[RRR] = i;
1496 reg[rrr] = XFIXNUM (value);
1497 break;
1498 }
1499 else if (SYMBOLP (content))
1500 CCL_CALL_FOR_MAP_INSTRUCTION (content, fin_ic);
1501 else
1502 CCL_INVALID_CMD;
1503 }
1504 if (i == j)
1505 reg[RRR] = -1;
1506 ic = fin_ic;
1507 }
1508 break;
1509
1510 case CCL_MapMultiple:
1511 {
1512 Lisp_Object map, content, attrib, value;
1513 EMACS_INT point;
1514 ptrdiff_t size, map_vector_size;
1515 int map_set_rest_length, fin_ic;
1516 int current_ic = this_ic;
1517
1518 /* inhibit recursive call on MapMultiple. */
1519 if (stack_idx_of_map_multiple > 0)
1520 {
1521 if (stack_idx_of_map_multiple <= stack_idx)
1522 {
1523 stack_idx_of_map_multiple = 0;
1524 mapping_stack_pointer = mapping_stack;
1525 CCL_INVALID_CMD;
1526 }
1527 }
1528 else
1529 mapping_stack_pointer = mapping_stack;
1530 stack_idx_of_map_multiple = 0;
1531
1532 /* Get number of maps and separators. */
1533 map_set_rest_length = XFIXNUM (ccl_prog[ic++]);
1534
1535 fin_ic = ic + map_set_rest_length;
1536 op = reg[rrr];
1537
1538 if ((map_set_rest_length > reg[RRR]) && (reg[RRR] >= 0))
1539 {
1540 ic += reg[RRR];
1541 i = reg[RRR];
1542 map_set_rest_length -= i;
1543 }
1544 else
1545 {
1546 ic = fin_ic;
1547 reg[RRR] = -1;
1548 mapping_stack_pointer = mapping_stack;
1549 break;
1550 }
1551
1552 if (mapping_stack_pointer <= (mapping_stack + 1))
1553 {
1554 /* Set up initial state. */
1555 mapping_stack_pointer = mapping_stack;
1556 PUSH_MAPPING_STACK (0, op);
1557 reg[RRR] = -1;
1558 }
1559 else
1560 {
1561 /* Recover after calling other ccl program. */
1562 int orig_op;
1563
1564 POP_MAPPING_STACK (map_set_rest_length, orig_op);
1565 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1566 switch (op)
1567 {
1568 case -1:
1569 /* Regard it as Qnil. */
1570 op = orig_op;
1571 i++;
1572 ic++;
1573 map_set_rest_length--;
1574 break;
1575 case -2:
1576 /* Regard it as Qt. */
1577 op = reg[rrr];
1578 i++;
1579 ic++;
1580 map_set_rest_length--;
1581 break;
1582 case -3:
1583 /* Regard it as Qlambda. */
1584 op = orig_op;
1585 i += map_set_rest_length;
1586 ic += map_set_rest_length;
1587 map_set_rest_length = 0;
1588 break;
1589 default:
1590 /* Regard it as normal mapping. */
1591 i += map_set_rest_length;
1592 ic += map_set_rest_length;
1593 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1594 break;
1595 }
1596 }
1597 if (!VECTORP (Vcode_conversion_map_vector))
1598 CCL_INVALID_CMD;
1599 map_vector_size = ASIZE (Vcode_conversion_map_vector);
1600
1601 do {
1602 for (;map_set_rest_length > 0;i++, ic++, map_set_rest_length--)
1603 {
1604 point = XFIXNUM (ccl_prog[ic]);
1605 if (point < 0)
1606 {
1607 /* +1 is for including separator. */
1608 point = -point + 1;
1609 if (mapping_stack_pointer
1610 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1611 CCL_INVALID_CMD;
1612 PUSH_MAPPING_STACK (map_set_rest_length - point,
1613 reg[rrr]);
1614 map_set_rest_length = point;
1615 reg[rrr] = op;
1616 continue;
1617 }
1618
1619 if (point >= map_vector_size) continue;
1620 map = AREF (Vcode_conversion_map_vector, point);
1621
1622 /* Check map validity. */
1623 if (!CONSP (map)) continue;
1624 map = XCDR (map);
1625 if (!VECTORP (map)) continue;
1626 size = ASIZE (map);
1627 if (size <= 1) continue;
1628
1629 content = AREF (map, 0);
1630
1631 /* check map type,
1632 [STARTPOINT VAL1 VAL2 ...] or
1633 [t ELEMENT STARTPOINT ENDPOINT] */
1634 if (FIXNUMP (content))
1635 {
1636 point = XFIXNUM (content);
1637 if (!(point <= op && op - point + 1 < size)) continue;
1638 content = AREF (map, op - point + 1);
1639 }
1640 else if (EQ (content, Qt))
1641 {
1642 if (size != 4) continue;
1643 if (FIXNUMP (AREF (map, 2))
1644 && XFIXNUM (AREF (map, 2)) <= op
1645 && FIXNUMP (AREF (map, 3))
1646 && op < XFIXNUM (AREF (map, 3)))
1647 content = AREF (map, 1);
1648 else
1649 continue;
1650 }
1651 else
1652 continue;
1653
1654 if (NILP (content))
1655 continue;
1656
1657 reg[RRR] = i;
1658 if (FIXNUMP (content) && IN_INT_RANGE (XFIXNUM (content)))
1659 {
1660 op = XFIXNUM (content);
1661 i += map_set_rest_length - 1;
1662 ic += map_set_rest_length - 1;
1663 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1664 map_set_rest_length++;
1665 }
1666 else if (CONSP (content))
1667 {
1668 attrib = XCAR (content);
1669 value = XCDR (content);
1670 if (! (FIXNUMP (attrib) && FIXNUMP (value)
1671 && IN_INT_RANGE (XFIXNUM (value))))
1672 continue;
1673 op = XFIXNUM (value);
1674 i += map_set_rest_length - 1;
1675 ic += map_set_rest_length - 1;
1676 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1677 map_set_rest_length++;
1678 }
1679 else if (EQ (content, Qt))
1680 {
1681 op = reg[rrr];
1682 }
1683 else if (EQ (content, Qlambda))
1684 {
1685 i += map_set_rest_length;
1686 ic += map_set_rest_length;
1687 break;
1688 }
1689 else if (SYMBOLP (content))
1690 {
1691 if (mapping_stack_pointer
1692 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1693 CCL_INVALID_CMD;
1694 PUSH_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1695 PUSH_MAPPING_STACK (map_set_rest_length, op);
1696 stack_idx_of_map_multiple = stack_idx + 1;
1697 CCL_CALL_FOR_MAP_INSTRUCTION (content, current_ic);
1698 }
1699 else
1700 CCL_INVALID_CMD;
1701 }
1702 if (mapping_stack_pointer <= (mapping_stack + 1))
1703 break;
1704 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1705 i += map_set_rest_length;
1706 ic += map_set_rest_length;
1707 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1708 } while (1);
1709
1710 ic = fin_ic;
1711 }
1712 reg[rrr] = op;
1713 break;
1714
1715 case CCL_MapSingle:
1716 {
1717 Lisp_Object map, attrib, value, content;
1718 int point;
1719 j = XFIXNUM (ccl_prog[ic++]); /* map_id */
1720 op = reg[rrr];
1721 if (! (VECTORP (Vcode_conversion_map_vector)
1722 && j < ASIZE (Vcode_conversion_map_vector)))
1723 {
1724 reg[RRR] = -1;
1725 break;
1726 }
1727 map = AREF (Vcode_conversion_map_vector, j);
1728 if (!CONSP (map))
1729 {
1730 reg[RRR] = -1;
1731 break;
1732 }
1733 map = XCDR (map);
1734 if (! (VECTORP (map)
1735 && 0 < ASIZE (map)
1736 && FIXNUMP (AREF (map, 0))
1737 && XFIXNUM (AREF (map, 0)) <= op
1738 && op - XFIXNUM (AREF (map, 0)) + 1 < ASIZE (map)))
1739 {
1740 reg[RRR] = -1;
1741 break;
1742 }
1743 point = op - XFIXNUM (AREF (map, 0)) + 1;
1744 reg[RRR] = 0;
1745 content = AREF (map, point);
1746 if (NILP (content))
1747 reg[RRR] = -1;
1748 else if (TYPE_RANGED_FIXNUMP (int, content))
1749 reg[rrr] = XFIXNUM (content);
1750 else if (EQ (content, Qt));
1751 else if (CONSP (content))
1752 {
1753 attrib = XCAR (content);
1754 value = XCDR (content);
1755 if (!FIXNUMP (attrib)
1756 || !TYPE_RANGED_FIXNUMP (int, value))
1757 continue;
1758 reg[rrr] = XFIXNUM (value);
1759 break;
1760 }
1761 else if (SYMBOLP (content))
1762 CCL_CALL_FOR_MAP_INSTRUCTION (content, ic);
1763 else
1764 reg[RRR] = -1;
1765 }
1766 break;
1767
1768 default:
1769 CCL_INVALID_CMD;
1770 }
1771 break;
1772
1773 default:
1774 CCL_INVALID_CMD;
1775 }
1776 }
1777
1778 ccl_error_handler:
1779 if (destination)
1780 {
1781 /* We can insert an error message only if DESTINATION is
1782 specified and we still have a room to store the message
1783 there. */
1784 char msg[256];
1785 int msglen;
1786
1787 if (!dst)
1788 dst = destination;
1789
1790 switch (ccl->status)
1791 {
1792 case CCL_STAT_INVALID_CMD:
1793 msglen = sprintf (msg,
1794 "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1795 code & 0x1Fu, code + 0u, this_ic);
1796 #ifdef CCL_DEBUG
1797 {
1798 int i = ccl_backtrace_idx - 1;
1799 int j;
1800
1801 if (dst + msglen <= (dst_bytes ? dst_end : src))
1802 {
1803 memcpy (dst, msg, msglen);
1804 dst += msglen;
1805 }
1806
1807 for (j = 0; j < CCL_DEBUG_BACKTRACE_LEN; j++, i--)
1808 {
1809 if (i < 0) i = CCL_DEBUG_BACKTRACE_LEN - 1;
1810 if (ccl_backtrace_table[i] == 0)
1811 break;
1812 msglen = sprintf (msg, " %d", ccl_backtrace_table[i]);
1813 if (dst + msglen > (dst_bytes ? dst_end : src))
1814 break;
1815 memcpy (dst, msg, msglen);
1816 dst += msglen;
1817 }
1818 goto ccl_finish;
1819 }
1820 #endif
1821 break;
1822
1823 case CCL_STAT_QUIT:
1824 msglen = ccl->quit_silently ? 0 : sprintf (msg, "\nCCL: Quitted.");
1825 break;
1826
1827 default:
1828 msglen = sprintf (msg, "\nCCL: Unknown error type (%d)", ccl->status);
1829 }
1830
1831 if (msglen <= dst_end - dst)
1832 {
1833 for (i = 0; i < msglen; i++)
1834 *dst++ = msg[i];
1835 }
1836
1837 if (ccl->status == CCL_STAT_INVALID_CMD)
1838 {
1839 #if 0 /* If the remaining bytes contain 0x80..0x9F, copying them
1840 results in an invalid multibyte sequence. */
1841
1842 /* Copy the remaining source data. */
1843 int i = src_end - src;
1844 if (dst_bytes && (dst_end - dst) < i)
1845 i = dst_end - dst;
1846 memcpy (dst, src, i);
1847 src += i;
1848 dst += i;
1849 #else
1850 /* Signal that we've consumed everything. */
1851 src = src_end;
1852 #endif
1853 }
1854 }
1855
1856 ccl_finish:
1857 ccl->ic = ic;
1858 ccl->stack_idx = stack_idx;
1859 ccl->prog = ccl_prog;
1860 ccl->consumed = src - source;
1861 if (dst != NULL)
1862 ccl->produced = dst - destination;
1863 else
1864 ccl->produced = 0;
1865 }
1866
1867 /* Resolve symbols in the specified CCL code (Lisp vector). This
1868 function converts symbols of code conversion maps and character
1869 translation tables embedded in the CCL code into their ID numbers.
1870
1871 The return value is a new vector in which all symbols are resolved,
1872 Qt if resolving of some symbol failed,
1873 or nil if CCL contains invalid data. */
1874
1875 static Lisp_Object
resolve_symbol_ccl_program(Lisp_Object ccl)1876 resolve_symbol_ccl_program (Lisp_Object ccl)
1877 {
1878 int i, veclen, unresolved = 0;
1879 Lisp_Object result, contents, val;
1880
1881 if (! (CCL_HEADER_MAIN < ASIZE (ccl) && ASIZE (ccl) <= INT_MAX))
1882 return Qnil;
1883 result = Fcopy_sequence (ccl);
1884 veclen = ASIZE (result);
1885
1886 for (i = 0; i < veclen; i++)
1887 {
1888 contents = AREF (result, i);
1889 if (TYPE_RANGED_FIXNUMP (int, contents))
1890 continue;
1891 else if (CONSP (contents)
1892 && SYMBOLP (XCAR (contents))
1893 && SYMBOLP (XCDR (contents)))
1894 {
1895 /* This is the new style for embedding symbols. The form is
1896 (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
1897 an index number. */
1898 val = Fget (XCAR (contents), XCDR (contents));
1899 if (RANGED_FIXNUMP (0, val, INT_MAX))
1900 ASET (result, i, val);
1901 else
1902 unresolved = 1;
1903 continue;
1904 }
1905 else if (SYMBOLP (contents))
1906 {
1907 /* This is the old style for embedding symbols. This style
1908 may lead to a bug if, for instance, a translation table
1909 and a code conversion map have the same name. */
1910 val = Fget (contents, Qtranslation_table_id);
1911 if (RANGED_FIXNUMP (0, val, INT_MAX))
1912 ASET (result, i, val);
1913 else
1914 {
1915 val = Fget (contents, Qcode_conversion_map_id);
1916 if (RANGED_FIXNUMP (0, val, INT_MAX))
1917 ASET (result, i, val);
1918 else
1919 {
1920 val = Fget (contents, Qccl_program_idx);
1921 if (RANGED_FIXNUMP (0, val, INT_MAX))
1922 ASET (result, i, val);
1923 else
1924 unresolved = 1;
1925 }
1926 }
1927 continue;
1928 }
1929 return Qnil;
1930 }
1931
1932 if (! (0 <= XFIXNUM (AREF (result, CCL_HEADER_BUF_MAG))
1933 && ASCENDING_ORDER (0, XFIXNUM (AREF (result, CCL_HEADER_EOF)),
1934 ASIZE (ccl))))
1935 return Qnil;
1936
1937 return (unresolved ? Qt : result);
1938 }
1939
1940 /* Return the compiled code (vector) of CCL program CCL_PROG.
1941 CCL_PROG is a name (symbol) of the program or already compiled
1942 code. If necessary, resolve symbols in the compiled code to index
1943 numbers. If we failed to get the compiled code or to resolve
1944 symbols, return Qnil. */
1945
1946 static Lisp_Object
ccl_get_compiled_code(Lisp_Object ccl_prog,ptrdiff_t * idx)1947 ccl_get_compiled_code (Lisp_Object ccl_prog, ptrdiff_t *idx)
1948 {
1949 Lisp_Object val, slot;
1950
1951 if (VECTORP (ccl_prog))
1952 {
1953 val = resolve_symbol_ccl_program (ccl_prog);
1954 *idx = -1;
1955 return (VECTORP (val) ? val : Qnil);
1956 }
1957 if (!SYMBOLP (ccl_prog))
1958 return Qnil;
1959
1960 val = Fget (ccl_prog, Qccl_program_idx);
1961 if (! FIXNATP (val)
1962 || XFIXNUM (val) >= ASIZE (Vccl_program_table))
1963 return Qnil;
1964 slot = AREF (Vccl_program_table, XFIXNUM (val));
1965 if (! VECTORP (slot)
1966 || ASIZE (slot) != 4
1967 || ! VECTORP (AREF (slot, 1)))
1968 return Qnil;
1969 *idx = XFIXNUM (val);
1970 if (NILP (AREF (slot, 2)))
1971 {
1972 val = resolve_symbol_ccl_program (AREF (slot, 1));
1973 if (! VECTORP (val))
1974 return Qnil;
1975 ASET (slot, 1, val);
1976 ASET (slot, 2, Qt);
1977 }
1978 return AREF (slot, 1);
1979 }
1980
1981 /* Setup fields of the structure pointed by CCL appropriately for the
1982 execution of CCL program CCL_PROG. CCL_PROG is the name (symbol)
1983 of the CCL program or the already compiled code (vector).
1984 Return true iff successful.
1985
1986 If CCL_PROG is nil, just reset the structure pointed by CCL. */
1987 bool
setup_ccl_program(struct ccl_program * ccl,Lisp_Object ccl_prog)1988 setup_ccl_program (struct ccl_program *ccl, Lisp_Object ccl_prog)
1989 {
1990 if (! NILP (ccl_prog))
1991 {
1992 struct Lisp_Vector *vp;
1993
1994 ccl_prog = ccl_get_compiled_code (ccl_prog, &ccl->idx);
1995 if (! VECTORP (ccl_prog))
1996 return false;
1997 vp = XVECTOR (ccl_prog);
1998 ccl->size = vp->header.size;
1999 ccl->prog = vp->contents;
2000 ccl->eof_ic = XFIXNUM (vp->contents[CCL_HEADER_EOF]);
2001 ccl->buf_magnification = XFIXNUM (vp->contents[CCL_HEADER_BUF_MAG]);
2002 if (ccl->idx >= 0)
2003 {
2004 Lisp_Object slot;
2005
2006 slot = AREF (Vccl_program_table, ccl->idx);
2007 ASET (slot, 3, Qnil);
2008 }
2009 }
2010 ccl->ic = CCL_HEADER_MAIN;
2011 memset (ccl->reg, 0, sizeof ccl->reg);
2012 ccl->last_block = false;
2013 ccl->status = 0;
2014 ccl->stack_idx = 0;
2015 ccl->quit_silently = false;
2016 return true;
2017 }
2018
2019
2020 DEFUN ("ccl-program-p", Fccl_program_p, Sccl_program_p, 1, 1, 0,
2021 doc: /* Return t if OBJECT is a CCL program name or a compiled CCL program code.
2022 See the documentation of `define-ccl-program' for the detail of CCL program. */)
2023 (Lisp_Object object)
2024 {
2025 Lisp_Object val;
2026
2027 if (VECTORP (object))
2028 {
2029 val = resolve_symbol_ccl_program (object);
2030 return (VECTORP (val) ? Qt : Qnil);
2031 }
2032 if (!SYMBOLP (object))
2033 return Qnil;
2034
2035 val = Fget (object, Qccl_program_idx);
2036 return ((! FIXNATP (val)
2037 || XFIXNUM (val) >= ASIZE (Vccl_program_table))
2038 ? Qnil : Qt);
2039 }
2040
2041 DEFUN ("ccl-execute", Fccl_execute, Sccl_execute, 2, 2, 0,
2042 doc: /* Execute CCL-PROGRAM with registers initialized by REGISTERS.
2043
2044 CCL-PROGRAM is a CCL program name (symbol)
2045 or compiled code generated by `ccl-compile' (for backward compatibility.
2046 In the latter case, the execution overhead is bigger than in the former).
2047 No I/O commands should appear in CCL-PROGRAM.
2048
2049 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value
2050 for the Nth register.
2051
2052 As side effect, each element of REGISTERS holds the value of
2053 the corresponding register after the execution.
2054
2055 See the documentation of `define-ccl-program' for a definition of CCL
2056 programs. */)
2057 (Lisp_Object ccl_prog, Lisp_Object reg)
2058 {
2059 struct ccl_program ccl;
2060 int i;
2061
2062 if (! setup_ccl_program (&ccl, ccl_prog))
2063 error ("Invalid CCL program");
2064
2065 CHECK_VECTOR (reg);
2066 if (ASIZE (reg) != 8)
2067 error ("Length of vector REGISTERS is not 8");
2068
2069 for (i = 0; i < 8; i++)
2070 {
2071 intmax_t n;
2072 ccl.reg[i] = ((INTEGERP (AREF (reg, i))
2073 && integer_to_intmax (AREF (reg, i), &n)
2074 && INT_MIN <= n && n <= INT_MAX)
2075 ? n : 0);
2076 }
2077
2078 ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil);
2079 maybe_quit ();
2080 if (ccl.status != CCL_STAT_SUCCESS)
2081 error ("Error in CCL program at %dth code", ccl.ic);
2082
2083 for (i = 0; i < 8; i++)
2084 ASET (reg, i, make_int (ccl.reg[i]));
2085 return Qnil;
2086 }
2087
2088 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, Sccl_execute_on_string,
2089 3, 5, 0,
2090 doc: /* Execute CCL-PROGRAM with initial STATUS on STRING.
2091
2092 CCL-PROGRAM is a symbol registered by `register-ccl-program',
2093 or a compiled code generated by `ccl-compile' (for backward compatibility,
2094 in this case, the execution is slower).
2095
2096 Read buffer is set to STRING, and write buffer is allocated automatically.
2097
2098 STATUS is a vector of [R0 R1 ... R7 IC], where
2099 R0..R7 are initial values of corresponding registers,
2100 IC is the instruction counter specifying from where to start the program.
2101 If R0..R7 are nil, they are initialized to 0.
2102 If IC is nil, it is initialized to head of the CCL program.
2103
2104 If optional 4th arg CONTINUE is non-nil, keep IC on read operation
2105 when read buffer is exhausted, else, IC is always set to the end of
2106 CCL-PROGRAM on exit.
2107
2108 It returns the contents of write buffer as a string,
2109 and as side effect, STATUS is updated.
2110 If the optional 5th arg UNIBYTE-P is non-nil, the returned string
2111 is a unibyte string. By default it is a multibyte string.
2112
2113 See the documentation of `define-ccl-program' for the detail of CCL program.
2114 usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBYTE-P) */)
2115 (Lisp_Object ccl_prog, Lisp_Object status, Lisp_Object str, Lisp_Object contin, Lisp_Object unibyte_p)
2116 {
2117 Lisp_Object val;
2118 struct ccl_program ccl;
2119 int i;
2120 ptrdiff_t outbufsize;
2121 unsigned char *outbuf, *outp;
2122 ptrdiff_t str_chars, str_bytes;
2123 #define CCL_EXECUTE_BUF_SIZE 1024
2124 int source[CCL_EXECUTE_BUF_SIZE], destination[CCL_EXECUTE_BUF_SIZE];
2125 ptrdiff_t consumed_chars, consumed_bytes, produced_chars;
2126 int buf_magnification;
2127
2128 if (! setup_ccl_program (&ccl, ccl_prog))
2129 error ("Invalid CCL program");
2130
2131 CHECK_VECTOR (status);
2132 if (ASIZE (status) != 9)
2133 error ("Length of vector STATUS is not 9");
2134 CHECK_STRING (str);
2135
2136 str_chars = SCHARS (str);
2137 str_bytes = SBYTES (str);
2138
2139 for (i = 0; i < 8; i++)
2140 {
2141 if (NILP (AREF (status, i)))
2142 ASET (status, i, make_fixnum (0));
2143 intmax_t n;
2144 if (INTEGERP (AREF (status, i))
2145 && integer_to_intmax (AREF (status, i), &n)
2146 && INT_MIN <= n && n <= INT_MAX)
2147 ccl.reg[i] = n;
2148 }
2149 intmax_t ic;
2150 if (INTEGERP (AREF (status, 8)) && integer_to_intmax (AREF (status, 8), &ic))
2151 {
2152 if (ccl.ic < ic && ic < ccl.size)
2153 ccl.ic = ic;
2154 }
2155
2156 buf_magnification = ccl.buf_magnification ? ccl.buf_magnification : 1;
2157 outbufsize = str_bytes;
2158 if (INT_MULTIPLY_WRAPV (buf_magnification, outbufsize, &outbufsize)
2159 || INT_ADD_WRAPV (256, outbufsize, &outbufsize))
2160 memory_full (SIZE_MAX);
2161 outp = outbuf = xmalloc (outbufsize);
2162
2163 consumed_chars = consumed_bytes = 0;
2164 produced_chars = 0;
2165 while (1)
2166 {
2167 const unsigned char *p = SDATA (str) + consumed_bytes;
2168 const unsigned char *endp = SDATA (str) + str_bytes;
2169 int j = 0;
2170 int *src, src_size;
2171
2172 if (endp - p == str_chars - consumed_chars)
2173 while (j < CCL_EXECUTE_BUF_SIZE && p < endp)
2174 source[j++] = *p++;
2175 else
2176 while (j < CCL_EXECUTE_BUF_SIZE && p < endp)
2177 source[j++] = string_char_advance (&p);
2178 consumed_chars += j;
2179 consumed_bytes = p - SDATA (str);
2180
2181 if (consumed_bytes == str_bytes)
2182 ccl.last_block = NILP (contin);
2183 src = source;
2184 src_size = j;
2185 while (1)
2186 {
2187 int max_expansion = NILP (unibyte_p) ? MAX_MULTIBYTE_LENGTH : 1;
2188 ptrdiff_t offset, shortfall;
2189 ccl_driver (&ccl, src, destination, src_size, CCL_EXECUTE_BUF_SIZE,
2190 Qnil);
2191 produced_chars += ccl.produced;
2192 offset = outp - outbuf;
2193 shortfall = ccl.produced * max_expansion - (outbufsize - offset);
2194 if (shortfall > 0)
2195 {
2196 outbuf = xpalloc (outbuf, &outbufsize, shortfall, -1, 1);
2197 outp = outbuf + offset;
2198 }
2199 if (NILP (unibyte_p))
2200 {
2201 for (j = 0; j < ccl.produced; j++)
2202 outp += CHAR_STRING (destination[j], outp);
2203 }
2204 else
2205 {
2206 for (j = 0; j < ccl.produced; j++)
2207 *outp++ = destination[j];
2208 }
2209 src += ccl.consumed;
2210 src_size -= ccl.consumed;
2211 if (ccl.status != CCL_STAT_SUSPEND_BY_DST)
2212 break;
2213 }
2214
2215 if (ccl.status != CCL_STAT_SUSPEND_BY_SRC
2216 || str_chars == consumed_chars)
2217 break;
2218 }
2219
2220 if (ccl.status == CCL_STAT_INVALID_CMD)
2221 error ("Error in CCL program at %dth code", ccl.ic);
2222 if (ccl.status == CCL_STAT_QUIT)
2223 error ("CCL program interrupted at %dth code", ccl.ic);
2224
2225 for (i = 0; i < 8; i++)
2226 ASET (status, i, make_int (ccl.reg[i]));
2227 ASET (status, 8, make_int (ccl.ic));
2228
2229 val = make_specified_string ((const char *) outbuf, produced_chars,
2230 outp - outbuf, NILP (unibyte_p));
2231 xfree (outbuf);
2232
2233 return val;
2234 }
2235
2236 DEFUN ("register-ccl-program", Fregister_ccl_program, Sregister_ccl_program,
2237 2, 2, 0,
2238 doc: /* Register CCL program CCL-PROG as NAME in `ccl-program-table'.
2239 CCL-PROG should be a compiled CCL program (vector), or nil.
2240 If it is nil, just reserve NAME as a CCL program name.
2241 Return index number of the registered CCL program. */)
2242 (Lisp_Object name, Lisp_Object ccl_prog)
2243 {
2244 ptrdiff_t len = ASIZE (Vccl_program_table);
2245 ptrdiff_t idx;
2246 Lisp_Object resolved;
2247
2248 CHECK_SYMBOL (name);
2249 resolved = Qnil;
2250 if (!NILP (ccl_prog))
2251 {
2252 CHECK_VECTOR (ccl_prog);
2253 resolved = resolve_symbol_ccl_program (ccl_prog);
2254 if (NILP (resolved))
2255 error ("Error in CCL program");
2256 if (VECTORP (resolved))
2257 {
2258 ccl_prog = resolved;
2259 resolved = Qt;
2260 }
2261 else
2262 resolved = Qnil;
2263 }
2264
2265 for (idx = 0; idx < len; idx++)
2266 {
2267 Lisp_Object slot;
2268
2269 slot = AREF (Vccl_program_table, idx);
2270 if (!VECTORP (slot))
2271 /* This is the first unused slot. Register NAME here. */
2272 break;
2273
2274 if (EQ (name, AREF (slot, 0)))
2275 {
2276 /* Update this slot. */
2277 ASET (slot, 1, ccl_prog);
2278 ASET (slot, 2, resolved);
2279 ASET (slot, 3, Qt);
2280 return make_fixnum (idx);
2281 }
2282 }
2283
2284 if (idx == len)
2285 /* Extend the table. */
2286 Vccl_program_table = larger_vector (Vccl_program_table, 1, -1);
2287
2288 ASET (Vccl_program_table, idx,
2289 CALLN (Fvector, name, ccl_prog, resolved, Qt));
2290
2291 Fput (name, Qccl_program_idx, make_fixnum (idx));
2292 return make_fixnum (idx);
2293 }
2294
2295 /* Register code conversion map.
2296 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
2297 The first element is the start code point.
2298 The other elements are mapped numbers.
2299 Symbol t means to map to an original number before mapping.
2300 Symbol nil means that the corresponding element is empty.
2301 Symbol lambda means to terminate mapping here.
2302 */
2303
2304 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map,
2305 Sregister_code_conversion_map,
2306 2, 2, 0,
2307 doc: /* Register SYMBOL as code conversion map MAP.
2308 Return index number of the registered map. */)
2309 (Lisp_Object symbol, Lisp_Object map)
2310 {
2311 ptrdiff_t len;
2312 ptrdiff_t i;
2313 Lisp_Object idx;
2314
2315 CHECK_SYMBOL (symbol);
2316 CHECK_VECTOR (map);
2317 if (! VECTORP (Vcode_conversion_map_vector))
2318 error ("Invalid code-conversion-map-vector");
2319
2320 len = ASIZE (Vcode_conversion_map_vector);
2321
2322 for (i = 0; i < len; i++)
2323 {
2324 Lisp_Object slot = AREF (Vcode_conversion_map_vector, i);
2325
2326 if (!CONSP (slot))
2327 break;
2328
2329 if (EQ (symbol, XCAR (slot)))
2330 {
2331 idx = make_fixnum (i);
2332 XSETCDR (slot, map);
2333 Fput (symbol, Qcode_conversion_map, map);
2334 Fput (symbol, Qcode_conversion_map_id, idx);
2335 return idx;
2336 }
2337 }
2338
2339 if (i == len)
2340 Vcode_conversion_map_vector = larger_vector (Vcode_conversion_map_vector,
2341 1, -1);
2342
2343 idx = make_fixnum (i);
2344 Fput (symbol, Qcode_conversion_map, map);
2345 Fput (symbol, Qcode_conversion_map_id, idx);
2346 ASET (Vcode_conversion_map_vector, i, Fcons (symbol, map));
2347 return idx;
2348 }
2349
2350
2351 void
syms_of_ccl(void)2352 syms_of_ccl (void)
2353 {
2354 staticpro (&Vccl_program_table);
2355 Vccl_program_table = make_nil_vector (32);
2356
2357 DEFSYM (Qccl, "ccl");
2358 DEFSYM (Qcclp, "cclp");
2359
2360 /* Symbols of ccl program have this property, a value of the property
2361 is an index for Vccl_program_table. */
2362 DEFSYM (Qccl_program_idx, "ccl-program-idx");
2363
2364 /* These symbols are properties which associate with code conversion
2365 map and their ID respectively. */
2366 DEFSYM (Qcode_conversion_map, "code-conversion-map");
2367 DEFSYM (Qcode_conversion_map_id, "code-conversion-map-id");
2368
2369 DEFVAR_LISP ("code-conversion-map-vector", Vcode_conversion_map_vector,
2370 doc: /* Vector of code conversion maps. */);
2371 Vcode_conversion_map_vector = make_nil_vector (16);
2372
2373 DEFVAR_LISP ("font-ccl-encoder-alist", Vfont_ccl_encoder_alist,
2374 doc: /* Alist of fontname patterns vs corresponding CCL program.
2375 Each element looks like (REGEXP . CCL-CODE),
2376 where CCL-CODE is a compiled CCL program.
2377 When a font whose name matches REGEXP is used for displaying a character,
2378 CCL-CODE is executed to calculate the code point in the font
2379 from the charset number and position code(s) of the character which are set
2380 in CCL registers R0, R1, and R2 before the execution.
2381 The code point in the font is set in CCL registers R1 and R2
2382 when the execution terminated.
2383 If the font is single-byte font, the register R2 is not used. */);
2384 Vfont_ccl_encoder_alist = Qnil;
2385
2386 DEFVAR_LISP ("translation-hash-table-vector", Vtranslation_hash_table_vector,
2387 doc: /* Vector containing all translation hash tables ever defined.
2388 Comprises pairs (SYMBOL . TABLE) where SYMBOL and TABLE were set up by calls
2389 to `define-translation-hash-table'. The vector is indexed by the table id
2390 used by CCL. */);
2391 Vtranslation_hash_table_vector = Qnil;
2392
2393 defsubr (&Sccl_program_p);
2394 defsubr (&Sccl_execute);
2395 defsubr (&Sccl_execute_on_string);
2396 defsubr (&Sregister_ccl_program);
2397 defsubr (&Sregister_code_conversion_map);
2398 }
2399