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