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 /* Work around GCC bug 109579
609 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109579
610 which causes GCC to mistakenly complain about
611 popping the mapping stack. */
612 #if GNUC_PREREQ (13, 0, 0)
613 # pragma GCC diagnostic ignored "-Wanalyzer-out-of-bounds"
614 #endif
615
616 #define POP_MAPPING_STACK(restlen, orig) \
617 do \
618 { \
619 mapping_stack_pointer--; \
620 (restlen) = mapping_stack_pointer->rest_length; \
621 (orig) = mapping_stack_pointer->orig_val; \
622 } \
623 while (0)
624
625 #define CCL_CALL_FOR_MAP_INSTRUCTION(symbol, ret_ic) \
626 do \
627 { \
628 struct ccl_program called_ccl; \
629 if (stack_idx >= 256 \
630 || ! setup_ccl_program (&called_ccl, (symbol))) \
631 { \
632 if (stack_idx > 0) \
633 { \
634 ccl_prog = ccl_prog_stack_struct[0].ccl_prog; \
635 ic = ccl_prog_stack_struct[0].ic; \
636 eof_ic = ccl_prog_stack_struct[0].eof_ic; \
637 } \
638 CCL_INVALID_CMD; \
639 } \
640 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; \
641 ccl_prog_stack_struct[stack_idx].ic = (ret_ic); \
642 ccl_prog_stack_struct[stack_idx].eof_ic = eof_ic; \
643 stack_idx++; \
644 ccl_prog = called_ccl.prog; \
645 ic = CCL_HEADER_MAIN; \
646 eof_ic = XFIXNAT (ccl_prog[CCL_HEADER_EOF]); \
647 goto ccl_repeat; \
648 } \
649 while (0)
650
651 #define CCL_MapSingle 0x12 /* Map by single code conversion map
652 1:ExtendedCOMMNDXXXRRRrrrXXXXX
653 2:MAP-ID
654 ------------------------------
655 Map reg[rrr] by MAP-ID.
656 If some valid mapping is found,
657 set reg[rrr] to the result,
658 else
659 set reg[RRR] to -1.
660 */
661
662 #define CCL_LookupIntConstTbl 0x13 /* Lookup multibyte character by
663 integer key. Afterwards R7 set
664 to 1 if lookup succeeded.
665 1:ExtendedCOMMNDRrrRRRXXXXXXXX
666 2:ARGUMENT(Hash table ID) */
667
668 #define CCL_LookupCharConstTbl 0x14 /* Lookup integer by multibyte
669 character key. Afterwards R7 set
670 to 1 if lookup succeeded.
671 1:ExtendedCOMMNDRrrRRRrrrXXXXX
672 2:ARGUMENT(Hash table ID) */
673
674 /* CCL arithmetic/logical operators. */
675 #define CCL_PLUS 0x00 /* X = Y + Z */
676 #define CCL_MINUS 0x01 /* X = Y - Z */
677 #define CCL_MUL 0x02 /* X = Y * Z */
678 #define CCL_DIV 0x03 /* X = Y / Z */
679 #define CCL_MOD 0x04 /* X = Y % Z */
680 #define CCL_AND 0x05 /* X = Y & Z */
681 #define CCL_OR 0x06 /* X = Y | Z */
682 #define CCL_XOR 0x07 /* X = Y ^ Z */
683 #define CCL_LSH 0x08 /* X = Y << Z */
684 #define CCL_RSH 0x09 /* X = Y >> Z */
685 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
686 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
687 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
688 #define CCL_LS 0x10 /* X = (X < Y) */
689 #define CCL_GT 0x11 /* X = (X > Y) */
690 #define CCL_EQ 0x12 /* X = (X == Y) */
691 #define CCL_LE 0x13 /* X = (X <= Y) */
692 #define CCL_GE 0x14 /* X = (X >= Y) */
693 #define CCL_NE 0x15 /* X = (X != Y) */
694
695 #define CCL_DECODE_SJIS 0x16 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
696 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
697 #define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z))
698 r[7] = LOWER_BYTE (SJIS (Y, Z) */
699
700 /* Terminate CCL program successfully. */
701 #define CCL_SUCCESS \
702 do \
703 { \
704 ccl->status = CCL_STAT_SUCCESS; \
705 goto ccl_finish; \
706 } \
707 while (0)
708
709 /* Suspend CCL program because of reading from empty input buffer or
710 writing to full output buffer. When this program is resumed, the
711 same I/O command is executed. */
712 #define CCL_SUSPEND(stat) \
713 do \
714 { \
715 ic--; \
716 ccl->status = stat; \
717 goto ccl_finish; \
718 } \
719 while (0)
720
721 /* Terminate CCL program because of invalid command. Should not occur
722 in the normal case. */
723 #ifndef CCL_DEBUG
724
725 #define CCL_INVALID_CMD \
726 do \
727 { \
728 ccl->status = CCL_STAT_INVALID_CMD; \
729 goto ccl_error_handler; \
730 } \
731 while (0)
732
733 #else
734
735 #define CCL_INVALID_CMD \
736 do \
737 { \
738 ccl_debug_hook (this_ic); \
739 ccl->status = CCL_STAT_INVALID_CMD; \
740 goto ccl_error_handler; \
741 } \
742 while (0)
743
744 #endif
745
746 /* Use "&" rather than "&&" to suppress a bogus GCC warning; see
747 <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=43772>. */
748 #define ASCENDING_ORDER(lo, med, hi) (((lo) <= (med)) & ((med) <= (hi)))
749
750 #define GET_CCL_RANGE(var, ccl_prog, ic, lo, hi) \
751 do \
752 { \
753 EMACS_INT prog_word = XFIXNUM ((ccl_prog)[ic]); \
754 if (! ASCENDING_ORDER (lo, prog_word, hi)) \
755 CCL_INVALID_CMD; \
756 (var) = prog_word; \
757 } \
758 while (0)
759
760 #define GET_CCL_CODE(code, ccl_prog, ic) \
761 GET_CCL_RANGE (code, ccl_prog, ic, CCL_CODE_MIN, CCL_CODE_MAX)
762
763 #define IN_INT_RANGE(val) ASCENDING_ORDER (INT_MIN, val, INT_MAX)
764
765 /* Encode one character CH to multibyte form and write to the current
766 output buffer. If CH is less than 256, CH is written as is. */
767 #define CCL_WRITE_CHAR(ch) \
768 do { \
769 if (! dst) \
770 CCL_INVALID_CMD; \
771 else if (dst < dst_end) \
772 *dst++ = (ch); \
773 else \
774 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
775 } while (0)
776
777 /* Write a string at ccl_prog[IC] of length LEN to the current output
778 buffer. */
779 #define CCL_WRITE_STRING(len) \
780 do { \
781 int ccli; \
782 if (!dst) \
783 CCL_INVALID_CMD; \
784 else if (dst + len <= dst_end) \
785 { \
786 if (XFIXNAT (ccl_prog[ic]) & 0x1000000) \
787 for (ccli = 0; ccli < len; ccli++) \
788 *dst++ = XFIXNAT (ccl_prog[ic + ccli]) & 0xFFFFFF; \
789 else \
790 for (ccli = 0; ccli < len; ccli++) \
791 *dst++ = ((XFIXNAT (ccl_prog[ic + (ccli / 3)])) \
792 >> ((2 - (ccli % 3)) * 8)) & 0xFF; \
793 } \
794 else \
795 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
796 } while (0)
797
798 /* Read one byte from the current input buffer into Rth register. */
799 #define CCL_READ_CHAR(r) \
800 do { \
801 if (! src) \
802 CCL_INVALID_CMD; \
803 else if (src < src_end) \
804 r = *src++; \
805 else if (ccl->last_block) \
806 { \
807 r = -1; \
808 ic = ccl->eof_ic; \
809 goto ccl_repeat; \
810 } \
811 else \
812 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
813 } while (0)
814
815 /* Decode CODE by a charset whose id is ID. If ID is 0, return CODE
816 as is for backward compatibility. Assume that we can use the
817 variable `charset'. */
818
819 #define CCL_DECODE_CHAR(id, code) \
820 ((id) == 0 ? (code) \
821 : (charset = CHARSET_FROM_ID ((id)), DECODE_CHAR (charset, (code))))
822
823 /* Encode character C by some of charsets in CHARSET_LIST. Set ID to
824 the id of the used charset, ENCODED to the result of encoding.
825 Assume that we can use the variable `charset'. */
826
827 #define CCL_ENCODE_CHAR(c, charset_list, id, encoded) \
828 do { \
829 unsigned ncode; \
830 \
831 charset = char_charset ((c), (charset_list), &ncode); \
832 if (! charset && ! NILP (charset_list)) \
833 charset = char_charset ((c), Qnil, &ncode); \
834 if (charset) \
835 { \
836 (id) = CHARSET_ID (charset); \
837 (encoded) = ncode; \
838 } \
839 } while (0)
840
841 /* Execute CCL code on characters at SOURCE (length SRC_SIZE). The
842 resulting text goes to a place pointed by DESTINATION, the length
843 of which should not exceed DST_SIZE. As a side effect, how many
844 characters are consumed and produced are recorded in CCL->consumed
845 and CCL->produced, and the contents of CCL registers are updated.
846 If SOURCE or DESTINATION is NULL, only operations on registers are
847 permitted. */
848
849 #ifdef CCL_DEBUG
850 #define CCL_DEBUG_BACKTRACE_LEN 256
851 int ccl_backtrace_table[CCL_DEBUG_BACKTRACE_LEN];
852 int ccl_backtrace_idx;
853
854 int
855 ccl_debug_hook (int ic)
856 {
857 return ic;
858 }
859
860 #endif
861
862 struct ccl_prog_stack
863 {
864 Lisp_Object *ccl_prog; /* Pointer to an array of CCL code. */
865 int ic; /* Instruction Counter. */
866 int eof_ic; /* Instruction Counter to jump on EOF. */
867 };
868
869 /* For the moment, we only support depth 256 of stack. */
870 static struct ccl_prog_stack ccl_prog_stack_struct[256];
871
872 /* Return a translation table of id number ID. */
873 static inline Lisp_Object
874 GET_TRANSLATION_TABLE (int id)
875 {
876 return XCDR (XVECTOR (Vtranslation_table_vector)->contents[id]);
877 }
878
879 void
880 ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size, int dst_size, Lisp_Object charset_list)
881 {
882 register int *reg = ccl->reg;
883 register int ic = ccl->ic;
884 register int code = 0, field1, field2;
885 register Lisp_Object *ccl_prog = ccl->prog;
886 int *src = source, *src_end = src + src_size;
887 int *dst = destination, *dst_end = dst + dst_size;
888 int jump_address;
889 int i = 0, j, op;
890 int stack_idx = ccl->stack_idx;
891 /* Instruction counter of the current CCL code. */
892 int this_ic = 0;
893 struct charset *charset;
894 int eof_ic = ccl->eof_ic;
895 int eof_hit = 0;
896
897 if (ccl->buf_magnification == 0) /* We can't read/produce any bytes. */
898 dst = NULL;
899
900 /* Set mapping stack pointer. */
901 mapping_stack_pointer = mapping_stack;
902
903 #ifdef CCL_DEBUG
904 ccl_backtrace_idx = 0;
905 #endif
906
907 for (;;)
908 {
909 ccl_repeat:
910 #ifdef CCL_DEBUG
911 ccl_backtrace_table[ccl_backtrace_idx++] = ic;
912 if (ccl_backtrace_idx >= CCL_DEBUG_BACKTRACE_LEN)
913 ccl_backtrace_idx = 0;
914 ccl_backtrace_table[ccl_backtrace_idx] = 0;
915 #endif
916
917 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
918 {
919 /* We can't just signal Qquit, instead break the loop as if
920 the whole data is processed. Don't reset Vquit_flag, it
921 must be handled later at a safer place. */
922 if (src)
923 src = source + src_size;
924 ccl->status = CCL_STAT_QUIT;
925 break;
926 }
927
928 this_ic = ic;
929 GET_CCL_CODE (code, ccl_prog, ic++);
930 field1 = code >> 8;
931 field2 = (code & 0xFF) >> 5;
932
933 #define rrr field2
934 #define RRR (field1 & 7)
935 #define Rrr ((field1 >> 3) & 7)
936 #define ADDR field1
937 #define EXCMD (field1 >> 6)
938
939 switch (code & 0x1F)
940 {
941 case CCL_SetRegister: /* 00000000000000000RRRrrrXXXXX */
942 reg[rrr] = reg[RRR];
943 break;
944
945 case CCL_SetShortConst: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
946 reg[rrr] = field1;
947 break;
948
949 case CCL_SetConst: /* 00000000000000000000rrrXXXXX */
950 reg[rrr] = XFIXNUM (ccl_prog[ic++]);
951 break;
952
953 case CCL_SetArray: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
954 i = reg[RRR];
955 j = field1 >> 3;
956 if (0 <= i && i < j)
957 reg[rrr] = XFIXNUM (ccl_prog[ic + i]);
958 ic += j;
959 break;
960
961 case CCL_Jump: /* A--D--D--R--E--S--S-000XXXXX */
962 ic += ADDR;
963 break;
964
965 case CCL_JumpCond: /* A--D--D--R--E--S--S-rrrXXXXX */
966 if (!reg[rrr])
967 ic += ADDR;
968 break;
969
970 case CCL_WriteRegisterJump: /* A--D--D--R--E--S--S-rrrXXXXX */
971 i = reg[rrr];
972 CCL_WRITE_CHAR (i);
973 ic += ADDR;
974 break;
975
976 case CCL_WriteRegisterReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
977 i = reg[rrr];
978 CCL_WRITE_CHAR (i);
979 ic++;
980 CCL_READ_CHAR (reg[rrr]);
981 ic += ADDR - 1;
982 break;
983
984 case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */
985 i = XFIXNUM (ccl_prog[ic]);
986 CCL_WRITE_CHAR (i);
987 ic += ADDR;
988 break;
989
990 case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
991 i = XFIXNUM (ccl_prog[ic]);
992 CCL_WRITE_CHAR (i);
993 ic++;
994 CCL_READ_CHAR (reg[rrr]);
995 ic += ADDR - 1;
996 break;
997
998 case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */
999 j = XFIXNUM (ccl_prog[ic++]);
1000 CCL_WRITE_STRING (j);
1001 ic += ADDR - 1;
1002 break;
1003
1004 case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
1005 i = reg[rrr];
1006 j = XFIXNUM (ccl_prog[ic]);
1007 if (0 <= i && i < j)
1008 {
1009 i = XFIXNUM (ccl_prog[ic + 1 + i]);
1010 CCL_WRITE_CHAR (i);
1011 }
1012 ic += j + 2;
1013 CCL_READ_CHAR (reg[rrr]);
1014 ic += ADDR - (j + 2);
1015 break;
1016
1017 case CCL_ReadJump: /* A--D--D--R--E--S--S-rrrYYYYY */
1018 CCL_READ_CHAR (reg[rrr]);
1019 ic += ADDR;
1020 break;
1021
1022 case CCL_ReadBranch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1023 CCL_READ_CHAR (reg[rrr]);
1024 FALLTHROUGH;
1025 case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1026 {
1027 int ioff = 0 <= reg[rrr] && reg[rrr] < field1 ? reg[rrr] : field1;
1028 int incr = XFIXNUM (ccl_prog[ic + ioff]);
1029 ic += incr;
1030 }
1031 break;
1032
1033 case CCL_ReadRegister: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
1034 while (1)
1035 {
1036 CCL_READ_CHAR (reg[rrr]);
1037 if (!field1) break;
1038 GET_CCL_CODE (code, ccl_prog, ic++);
1039 field1 = code >> 8;
1040 field2 = (code & 0xFF) >> 5;
1041 }
1042 break;
1043
1044 case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */
1045 rrr = 7;
1046 i = reg[RRR];
1047 j = XFIXNUM (ccl_prog[ic]);
1048 op = field1 >> 6;
1049 jump_address = ic + 1;
1050 goto ccl_set_expr;
1051
1052 case CCL_WriteRegister: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
1053 while (1)
1054 {
1055 i = reg[rrr];
1056 CCL_WRITE_CHAR (i);
1057 if (!field1) break;
1058 GET_CCL_CODE (code, ccl_prog, ic++);
1059 field1 = code >> 8;
1060 field2 = (code & 0xFF) >> 5;
1061 }
1062 break;
1063
1064 case CCL_WriteExprRegister: /* 1:00000OPERATIONRrrRRR000XXXXX */
1065 rrr = 7;
1066 i = reg[RRR];
1067 j = reg[Rrr];
1068 op = field1 >> 6;
1069 jump_address = ic;
1070 goto ccl_set_expr;
1071
1072 case CCL_Call: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
1073 {
1074 Lisp_Object slot;
1075 int prog_id;
1076
1077 /* If FFF is nonzero, the CCL program ID is in the
1078 following code. */
1079 if (rrr)
1080 prog_id = XFIXNUM (ccl_prog[ic++]);
1081 else
1082 prog_id = field1;
1083
1084 if (stack_idx >= 256
1085 || prog_id < 0
1086 || prog_id >= ASIZE (Vccl_program_table)
1087 || (slot = AREF (Vccl_program_table, prog_id), !VECTORP (slot))
1088 || !VECTORP (AREF (slot, 1)))
1089 {
1090 if (stack_idx > 0)
1091 {
1092 ccl_prog = ccl_prog_stack_struct[0].ccl_prog;
1093 ic = ccl_prog_stack_struct[0].ic;
1094 eof_ic = ccl_prog_stack_struct[0].eof_ic;
1095 }
1096 CCL_INVALID_CMD;
1097 }
1098
1099 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog;
1100 ccl_prog_stack_struct[stack_idx].ic = ic;
1101 ccl_prog_stack_struct[stack_idx].eof_ic = eof_ic;
1102 stack_idx++;
1103 ccl_prog = XVECTOR (AREF (slot, 1))->contents;
1104 ic = CCL_HEADER_MAIN;
1105 eof_ic = XFIXNAT (ccl_prog[CCL_HEADER_EOF]);
1106 }
1107 break;
1108
1109 case CCL_WriteConstString: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1110 if (!rrr)
1111 CCL_WRITE_CHAR (field1);
1112 else
1113 {
1114 CCL_WRITE_STRING (field1);
1115 ic += (field1 + 2) / 3;
1116 }
1117 break;
1118
1119 case CCL_WriteArray: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1120 i = reg[rrr];
1121 if (0 <= i && i < field1)
1122 {
1123 j = XFIXNUM (ccl_prog[ic + i]);
1124 CCL_WRITE_CHAR (j);
1125 }
1126 ic += field1;
1127 break;
1128
1129 case CCL_End: /* 0000000000000000000000XXXXX */
1130 if (stack_idx > 0)
1131 {
1132 stack_idx--;
1133 ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog;
1134 ic = ccl_prog_stack_struct[stack_idx].ic;
1135 eof_ic = ccl_prog_stack_struct[stack_idx].eof_ic;
1136 if (eof_hit)
1137 ic = eof_ic;
1138 break;
1139 }
1140 if (src)
1141 src = src_end;
1142 /* ccl->ic should points to this command code again to
1143 suppress further processing. */
1144 ic--;
1145 CCL_SUCCESS;
1146
1147 case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */
1148 i = XFIXNUM (ccl_prog[ic++]);
1149 op = field1 >> 6;
1150 goto ccl_expr_self;
1151
1152 case CCL_ExprSelfReg: /* 00000OPERATION000RRRrrrXXXXX */
1153 i = reg[RRR];
1154 op = field1 >> 6;
1155
1156 ccl_expr_self:
1157 switch (op)
1158 {
1159 case CCL_PLUS: ckd_add (®[rrr], reg[rrr], i); break;
1160 case CCL_MINUS: ckd_sub (®[rrr], reg[rrr], i); break;
1161 case CCL_MUL: ckd_mul (®[rrr], reg[rrr], i); break;
1162 case CCL_DIV:
1163 if (!i)
1164 CCL_INVALID_CMD;
1165 if (!INT_DIVIDE_OVERFLOW (reg[rrr], i))
1166 reg[rrr] /= i;
1167 break;
1168 case CCL_MOD:
1169 if (!i)
1170 CCL_INVALID_CMD;
1171 reg[rrr] = i == -1 ? 0 : reg[rrr] % i;
1172 break;
1173 case CCL_AND: reg[rrr] &= i; break;
1174 case CCL_OR: reg[rrr] |= i; break;
1175 case CCL_XOR: reg[rrr] ^= i; break;
1176 case CCL_LSH:
1177 if (i < 0)
1178 CCL_INVALID_CMD;
1179 reg[rrr] = i < UINT_WIDTH ? (unsigned) reg[rrr] << i : 0;
1180 break;
1181 case CCL_RSH:
1182 if (i < 0)
1183 CCL_INVALID_CMD;
1184 reg[rrr] = reg[rrr] >> min (i, INT_WIDTH - 1);
1185 break;
1186 case CCL_LSH8:
1187 reg[rrr] = (unsigned) reg[rrr] << 8;
1188 reg[rrr] |= i;
1189 break;
1190 case CCL_RSH8: reg[7] = reg[rrr] & 0xFF; reg[rrr] >>= 8; break;
1191 case CCL_DIVMOD:
1192 if (!i)
1193 CCL_INVALID_CMD;
1194 if (i == -1)
1195 {
1196 reg[7] = 0;
1197 ckd_sub (®[rrr], 0, reg[rrr]);
1198 }
1199 else
1200 {
1201 reg[7] = reg[rrr] % i;
1202 reg[rrr] /= i;
1203 }
1204 break;
1205 case CCL_LS: reg[rrr] = reg[rrr] < i; break;
1206 case CCL_GT: reg[rrr] = reg[rrr] > i; break;
1207 case CCL_EQ: reg[rrr] = reg[rrr] == i; break;
1208 case CCL_LE: reg[rrr] = reg[rrr] <= i; break;
1209 case CCL_GE: reg[rrr] = reg[rrr] >= i; break;
1210 case CCL_NE: reg[rrr] = reg[rrr] != i; break;
1211 default: CCL_INVALID_CMD;
1212 }
1213 break;
1214
1215 case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */
1216 i = reg[RRR];
1217 j = XFIXNUM (ccl_prog[ic++]);
1218 op = field1 >> 6;
1219 jump_address = ic;
1220 goto ccl_set_expr;
1221
1222 case CCL_SetExprReg: /* 00000OPERATIONRrrRRRrrrXXXXX */
1223 i = reg[RRR];
1224 j = reg[Rrr];
1225 op = field1 >> 6;
1226 jump_address = ic;
1227 goto ccl_set_expr;
1228
1229 case CCL_ReadJumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1230 CCL_READ_CHAR (reg[rrr]);
1231 FALLTHROUGH;
1232 case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1233 i = reg[rrr];
1234 jump_address = ic + ADDR;
1235 op = XFIXNUM (ccl_prog[ic++]);
1236 j = XFIXNUM (ccl_prog[ic++]);
1237 rrr = 7;
1238 goto ccl_set_expr;
1239
1240 case CCL_ReadJumpCondExprReg: /* A--D--D--R--E--S--S-rrrXXXXX */
1241 CCL_READ_CHAR (reg[rrr]);
1242 FALLTHROUGH;
1243 case CCL_JumpCondExprReg:
1244 i = reg[rrr];
1245 jump_address = ic + ADDR;
1246 op = XFIXNUM (ccl_prog[ic++]);
1247 GET_CCL_RANGE (j, ccl_prog, ic++, 0, 7);
1248 j = reg[j];
1249 rrr = 7;
1250
1251 ccl_set_expr:
1252 switch (op)
1253 {
1254 case CCL_PLUS: ckd_add (®[rrr], i, j); break;
1255 case CCL_MINUS: ckd_sub (®[rrr], i, j); break;
1256 case CCL_MUL: ckd_mul (®[rrr], i, j); break;
1257 case CCL_DIV:
1258 if (!j)
1259 CCL_INVALID_CMD;
1260 if (!INT_DIVIDE_OVERFLOW (i, j))
1261 i /= j;
1262 reg[rrr] = i;
1263 break;
1264 case CCL_MOD:
1265 if (!j)
1266 CCL_INVALID_CMD;
1267 reg[rrr] = j == -1 ? 0 : i % j;
1268 break;
1269 case CCL_AND: reg[rrr] = i & j; break;
1270 case CCL_OR: reg[rrr] = i | j; break;
1271 case CCL_XOR: reg[rrr] = i ^ j; break;
1272 case CCL_LSH:
1273 if (j < 0)
1274 CCL_INVALID_CMD;
1275 reg[rrr] = j < UINT_WIDTH ? (unsigned) i << j : 0;
1276 break;
1277 case CCL_RSH:
1278 if (j < 0)
1279 CCL_INVALID_CMD;
1280 reg[rrr] = i >> min (j, INT_WIDTH - 1);
1281 break;
1282 case CCL_LSH8:
1283 reg[rrr] = ((unsigned) i << 8) | j;
1284 break;
1285 case CCL_RSH8: reg[rrr] = i >> 8; reg[7] = i & 0xFF; break;
1286 case CCL_DIVMOD:
1287 if (!j)
1288 CCL_INVALID_CMD;
1289 if (j == -1)
1290 {
1291 ckd_sub (®[rrr], 0, reg[rrr]);
1292 reg[7] = 0;
1293 }
1294 else
1295 {
1296 reg[rrr] = i / j;
1297 reg[7] = i % j;
1298 }
1299 break;
1300 case CCL_LS: reg[rrr] = i < j; break;
1301 case CCL_GT: reg[rrr] = i > j; break;
1302 case CCL_EQ: reg[rrr] = i == j; break;
1303 case CCL_LE: reg[rrr] = i <= j; break;
1304 case CCL_GE: reg[rrr] = i >= j; break;
1305 case CCL_NE: reg[rrr] = i != j; break;
1306 case CCL_DECODE_SJIS:
1307 {
1308 i = ((unsigned) i << 8) | j;
1309 SJIS_TO_JIS (i);
1310 reg[rrr] = i >> 8;
1311 reg[7] = i & 0xFF;
1312 break;
1313 }
1314 case CCL_ENCODE_SJIS:
1315 {
1316 i = ((unsigned) i << 8) | j;
1317 JIS_TO_SJIS (i);
1318 reg[rrr] = i >> 8;
1319 reg[7] = i & 0xFF;
1320 break;
1321 }
1322 default: CCL_INVALID_CMD;
1323 }
1324 code &= 0x1F;
1325 if (code == CCL_WriteExprConst || code == CCL_WriteExprRegister)
1326 {
1327 i = reg[rrr];
1328 CCL_WRITE_CHAR (i);
1329 ic = jump_address;
1330 }
1331 else if (!reg[rrr])
1332 ic = jump_address;
1333 break;
1334
1335 case CCL_Extension:
1336 switch (EXCMD)
1337 {
1338 case CCL_ReadMultibyteChar2:
1339 if (!src)
1340 CCL_INVALID_CMD;
1341 CCL_READ_CHAR (i);
1342 CCL_ENCODE_CHAR (i, charset_list, reg[RRR], reg[rrr]);
1343 break;
1344
1345 case CCL_WriteMultibyteChar2:
1346 if (! dst)
1347 CCL_INVALID_CMD;
1348 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1349 CCL_WRITE_CHAR (i);
1350 break;
1351
1352 case CCL_TranslateCharacter:
1353 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1354 op = translate_char (GET_TRANSLATION_TABLE (reg[Rrr]), i);
1355 CCL_ENCODE_CHAR (op, charset_list, reg[RRR], reg[rrr]);
1356 break;
1357
1358 case CCL_TranslateCharacterConstTbl:
1359 {
1360 ptrdiff_t eop;
1361 GET_CCL_RANGE (eop, ccl_prog, ic++, 0,
1362 (VECTORP (Vtranslation_table_vector)
1363 ? ASIZE (Vtranslation_table_vector)
1364 : -1));
1365 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1366 op = translate_char (GET_TRANSLATION_TABLE (eop), i);
1367 CCL_ENCODE_CHAR (op, charset_list, reg[RRR], reg[rrr]);
1368 }
1369 break;
1370
1371 case CCL_LookupIntConstTbl:
1372 {
1373 ptrdiff_t eop;
1374 struct Lisp_Hash_Table *h;
1375 GET_CCL_RANGE (eop, ccl_prog, ic++, 0,
1376 (VECTORP (Vtranslation_hash_table_vector)
1377 ? ASIZE (Vtranslation_hash_table_vector)
1378 : -1));
1379 h = GET_HASH_TABLE (eop);
1380
1381 eop = (FIXNUM_OVERFLOW_P (reg[RRR])
1382 ? -1
1383 : hash_lookup (h, make_fixnum (reg[RRR]), NULL));
1384 if (eop >= 0)
1385 {
1386 Lisp_Object opl;
1387 opl = HASH_VALUE (h, eop);
1388 if (! (IN_INT_RANGE (eop) && CHARACTERP (opl)))
1389 CCL_INVALID_CMD;
1390 reg[RRR] = charset_unicode;
1391 reg[rrr] = XFIXNUM (opl);
1392 reg[7] = 1; /* r7 true for success */
1393 }
1394 else
1395 reg[7] = 0;
1396 }
1397 break;
1398
1399 case CCL_LookupCharConstTbl:
1400 {
1401 ptrdiff_t eop;
1402 struct Lisp_Hash_Table *h;
1403 GET_CCL_RANGE (eop, ccl_prog, ic++, 0,
1404 (VECTORP (Vtranslation_hash_table_vector)
1405 ? ASIZE (Vtranslation_hash_table_vector)
1406 : -1));
1407 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1408 h = GET_HASH_TABLE (eop);
1409
1410 eop = (FIXNUM_OVERFLOW_P (i)
1411 ? -1
1412 : hash_lookup (h, make_fixnum (i), NULL));
1413 if (eop >= 0)
1414 {
1415 Lisp_Object opl;
1416 opl = HASH_VALUE (h, eop);
1417 if (! (FIXNUMP (opl) && IN_INT_RANGE (XFIXNUM (opl))))
1418 CCL_INVALID_CMD;
1419 reg[RRR] = XFIXNUM (opl);
1420 reg[7] = 1; /* r7 true for success */
1421 }
1422 else
1423 reg[7] = 0;
1424 }
1425 break;
1426
1427 case CCL_IterateMultipleMap:
1428 {
1429 Lisp_Object map, content, attrib, value;
1430 EMACS_INT point;
1431 ptrdiff_t size;
1432 int fin_ic;
1433
1434 j = XFIXNUM (ccl_prog[ic++]); /* number of maps. */
1435 fin_ic = ic + j;
1436 op = reg[rrr];
1437 if ((j > reg[RRR]) && (j >= 0))
1438 {
1439 ic += reg[RRR];
1440 i = reg[RRR];
1441 }
1442 else
1443 {
1444 reg[RRR] = -1;
1445 ic = fin_ic;
1446 break;
1447 }
1448
1449 for (;i < j;i++)
1450 {
1451 if (!VECTORP (Vcode_conversion_map_vector)) continue;
1452 size = ASIZE (Vcode_conversion_map_vector);
1453 point = XFIXNUM (ccl_prog[ic++]);
1454 if (! (0 <= point && point < size)) continue;
1455 map = AREF (Vcode_conversion_map_vector, point);
1456
1457 /* Check map validity. */
1458 if (!CONSP (map)) continue;
1459 map = XCDR (map);
1460 if (!VECTORP (map)) continue;
1461 size = ASIZE (map);
1462 if (size <= 1) continue;
1463
1464 content = AREF (map, 0);
1465
1466 /* check map type,
1467 [STARTPOINT VAL1 VAL2 ...] or
1468 [t ELEMENT STARTPOINT ENDPOINT] */
1469 if (FIXNUMP (content))
1470 {
1471 point = XFIXNUM (content);
1472 if (!(point <= op && op - point + 1 < size)) continue;
1473 content = AREF (map, op - point + 1);
1474 }
1475 else if (EQ (content, Qt))
1476 {
1477 if (size != 4) continue;
1478 if (FIXNUMP (AREF (map, 2))
1479 && XFIXNUM (AREF (map, 2)) <= op
1480 && FIXNUMP (AREF (map, 3))
1481 && op < XFIXNUM (AREF (map, 3)))
1482 content = AREF (map, 1);
1483 else
1484 continue;
1485 }
1486 else
1487 continue;
1488
1489 if (NILP (content))
1490 continue;
1491 else if (FIXNUMP (content) && IN_INT_RANGE (XFIXNUM (content)))
1492 {
1493 reg[RRR] = i;
1494 reg[rrr] = XFIXNUM (content);
1495 break;
1496 }
1497 else if (EQ (content, Qt) || EQ (content, Qlambda))
1498 {
1499 reg[RRR] = i;
1500 break;
1501 }
1502 else if (CONSP (content))
1503 {
1504 attrib = XCAR (content);
1505 value = XCDR (content);
1506 if (! (FIXNUMP (attrib) && FIXNUMP (value)
1507 && IN_INT_RANGE (XFIXNUM (value))))
1508 continue;
1509 reg[RRR] = i;
1510 reg[rrr] = XFIXNUM (value);
1511 break;
1512 }
1513 else if (SYMBOLP (content))
1514 CCL_CALL_FOR_MAP_INSTRUCTION (content, fin_ic);
1515 else
1516 CCL_INVALID_CMD;
1517 }
1518 if (i == j)
1519 reg[RRR] = -1;
1520 ic = fin_ic;
1521 }
1522 break;
1523
1524 case CCL_MapMultiple:
1525 {
1526 Lisp_Object map, content, attrib, value;
1527 EMACS_INT point;
1528 ptrdiff_t size, map_vector_size;
1529 int map_set_rest_length, fin_ic;
1530 int current_ic = this_ic;
1531
1532 /* inhibit recursive call on MapMultiple. */
1533 if (stack_idx_of_map_multiple > 0)
1534 {
1535 if (stack_idx_of_map_multiple <= stack_idx)
1536 {
1537 stack_idx_of_map_multiple = 0;
1538 mapping_stack_pointer = mapping_stack;
1539 CCL_INVALID_CMD;
1540 }
1541 }
1542 else
1543 mapping_stack_pointer = mapping_stack;
1544 stack_idx_of_map_multiple = 0;
1545
1546 /* Get number of maps and separators. */
1547 map_set_rest_length = XFIXNUM (ccl_prog[ic++]);
1548
1549 fin_ic = ic + map_set_rest_length;
1550 op = reg[rrr];
1551
1552 if ((map_set_rest_length > reg[RRR]) && (reg[RRR] >= 0))
1553 {
1554 ic += reg[RRR];
1555 i = reg[RRR];
1556 map_set_rest_length -= i;
1557 }
1558 else
1559 {
1560 ic = fin_ic;
1561 reg[RRR] = -1;
1562 mapping_stack_pointer = mapping_stack;
1563 break;
1564 }
1565
1566 if (mapping_stack_pointer <= (mapping_stack + 1))
1567 {
1568 /* Set up initial state. */
1569 mapping_stack_pointer = mapping_stack;
1570 PUSH_MAPPING_STACK (0, op);
1571 reg[RRR] = -1;
1572 }
1573 else
1574 {
1575 /* Recover after calling other ccl program. */
1576 int orig_op;
1577
1578 POP_MAPPING_STACK (map_set_rest_length, orig_op);
1579 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1580 switch (op)
1581 {
1582 case -1:
1583 /* Regard it as Qnil. */
1584 op = orig_op;
1585 i++;
1586 ic++;
1587 map_set_rest_length--;
1588 break;
1589 case -2:
1590 /* Regard it as Qt. */
1591 op = reg[rrr];
1592 i++;
1593 ic++;
1594 map_set_rest_length--;
1595 break;
1596 case -3:
1597 /* Regard it as Qlambda. */
1598 op = orig_op;
1599 i += map_set_rest_length;
1600 ic += map_set_rest_length;
1601 map_set_rest_length = 0;
1602 break;
1603 default:
1604 /* Regard it as normal mapping. */
1605 i += map_set_rest_length;
1606 ic += map_set_rest_length;
1607 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1608 break;
1609 }
1610 }
1611 if (!VECTORP (Vcode_conversion_map_vector))
1612 CCL_INVALID_CMD;
1613 map_vector_size = ASIZE (Vcode_conversion_map_vector);
1614
1615 do {
1616 for (;map_set_rest_length > 0;i++, ic++, map_set_rest_length--)
1617 {
1618 point = XFIXNUM (ccl_prog[ic]);
1619 if (point < 0)
1620 {
1621 /* +1 is for including separator. */
1622 point = -point + 1;
1623 if (mapping_stack_pointer
1624 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1625 CCL_INVALID_CMD;
1626 PUSH_MAPPING_STACK (map_set_rest_length - point,
1627 reg[rrr]);
1628 map_set_rest_length = point;
1629 reg[rrr] = op;
1630 continue;
1631 }
1632
1633 if (point >= map_vector_size) continue;
1634 map = AREF (Vcode_conversion_map_vector, point);
1635
1636 /* Check map validity. */
1637 if (!CONSP (map)) continue;
1638 map = XCDR (map);
1639 if (!VECTORP (map)) continue;
1640 size = ASIZE (map);
1641 if (size <= 1) continue;
1642
1643 content = AREF (map, 0);
1644
1645 /* check map type,
1646 [STARTPOINT VAL1 VAL2 ...] or
1647 [t ELEMENT STARTPOINT ENDPOINT] */
1648 if (FIXNUMP (content))
1649 {
1650 point = XFIXNUM (content);
1651 if (!(point <= op && op - point + 1 < size)) continue;
1652 content = AREF (map, op - point + 1);
1653 }
1654 else if (EQ (content, Qt))
1655 {
1656 if (size != 4) continue;
1657 if (FIXNUMP (AREF (map, 2))
1658 && XFIXNUM (AREF (map, 2)) <= op
1659 && FIXNUMP (AREF (map, 3))
1660 && op < XFIXNUM (AREF (map, 3)))
1661 content = AREF (map, 1);
1662 else
1663 continue;
1664 }
1665 else
1666 continue;
1667
1668 if (NILP (content))
1669 continue;
1670
1671 reg[RRR] = i;
1672 if (FIXNUMP (content) && IN_INT_RANGE (XFIXNUM (content)))
1673 {
1674 op = XFIXNUM (content);
1675 i += map_set_rest_length - 1;
1676 ic += map_set_rest_length - 1;
1677 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1678 map_set_rest_length++;
1679 }
1680 else if (CONSP (content))
1681 {
1682 attrib = XCAR (content);
1683 value = XCDR (content);
1684 if (! (FIXNUMP (attrib) && FIXNUMP (value)
1685 && IN_INT_RANGE (XFIXNUM (value))))
1686 continue;
1687 op = XFIXNUM (value);
1688 i += map_set_rest_length - 1;
1689 ic += map_set_rest_length - 1;
1690 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1691 map_set_rest_length++;
1692 }
1693 else if (EQ (content, Qt))
1694 {
1695 op = reg[rrr];
1696 }
1697 else if (EQ (content, Qlambda))
1698 {
1699 i += map_set_rest_length;
1700 ic += map_set_rest_length;
1701 break;
1702 }
1703 else if (SYMBOLP (content))
1704 {
1705 if (mapping_stack_pointer
1706 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1707 CCL_INVALID_CMD;
1708 PUSH_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1709 PUSH_MAPPING_STACK (map_set_rest_length, op);
1710 stack_idx_of_map_multiple = stack_idx + 1;
1711 CCL_CALL_FOR_MAP_INSTRUCTION (content, current_ic);
1712 }
1713 else
1714 CCL_INVALID_CMD;
1715 }
1716 if (mapping_stack_pointer <= (mapping_stack + 1))
1717 break;
1718 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1719 i += map_set_rest_length;
1720 ic += map_set_rest_length;
1721 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1722 } while (1);
1723
1724 ic = fin_ic;
1725 }
1726 reg[rrr] = op;
1727 break;
1728
1729 case CCL_MapSingle:
1730 {
1731 Lisp_Object map, attrib, value, content;
1732 int point;
1733 j = XFIXNUM (ccl_prog[ic++]); /* map_id */
1734 op = reg[rrr];
1735 if (! (VECTORP (Vcode_conversion_map_vector)
1736 && j < ASIZE (Vcode_conversion_map_vector)))
1737 {
1738 reg[RRR] = -1;
1739 break;
1740 }
1741 map = AREF (Vcode_conversion_map_vector, j);
1742 if (!CONSP (map))
1743 {
1744 reg[RRR] = -1;
1745 break;
1746 }
1747 map = XCDR (map);
1748 if (! (VECTORP (map)
1749 && 0 < ASIZE (map)
1750 && FIXNUMP (AREF (map, 0))
1751 && XFIXNUM (AREF (map, 0)) <= op
1752 && op - XFIXNUM (AREF (map, 0)) + 1 < ASIZE (map)))
1753 {
1754 reg[RRR] = -1;
1755 break;
1756 }
1757 point = op - XFIXNUM (AREF (map, 0)) + 1;
1758 reg[RRR] = 0;
1759 content = AREF (map, point);
1760 if (NILP (content))
1761 reg[RRR] = -1;
1762 else if (TYPE_RANGED_FIXNUMP (int, content))
1763 reg[rrr] = XFIXNUM (content);
1764 else if (EQ (content, Qt));
1765 else if (CONSP (content))
1766 {
1767 attrib = XCAR (content);
1768 value = XCDR (content);
1769 if (!FIXNUMP (attrib)
1770 || !TYPE_RANGED_FIXNUMP (int, value))
1771 continue;
1772 reg[rrr] = XFIXNUM (value);
1773 break;
1774 }
1775 else if (SYMBOLP (content))
1776 CCL_CALL_FOR_MAP_INSTRUCTION (content, ic);
1777 else
1778 reg[RRR] = -1;
1779 }
1780 break;
1781
1782 default:
1783 CCL_INVALID_CMD;
1784 }
1785 break;
1786
1787 default:
1788 CCL_INVALID_CMD;
1789 }
1790 }
1791
1792 ccl_error_handler:
1793 if (destination)
1794 {
1795 /* We can insert an error message only if DESTINATION is
1796 specified and we still have a room to store the message
1797 there. */
1798 char msg[256];
1799 int msglen;
1800
1801 if (!dst)
1802 dst = destination;
1803
1804 switch (ccl->status)
1805 {
1806 case CCL_STAT_INVALID_CMD:
1807 msglen = sprintf (msg,
1808 "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1809 code & 0x1Fu, code + 0u, this_ic);
1810 #ifdef CCL_DEBUG
1811 {
1812 int i = ccl_backtrace_idx - 1;
1813 int j;
1814
1815 if (dst + msglen <= (dst_bytes ? dst_end : src))
1816 {
1817 memcpy (dst, msg, msglen);
1818 dst += msglen;
1819 }
1820
1821 for (j = 0; j < CCL_DEBUG_BACKTRACE_LEN; j++, i--)
1822 {
1823 if (i < 0) i = CCL_DEBUG_BACKTRACE_LEN - 1;
1824 if (ccl_backtrace_table[i] == 0)
1825 break;
1826 msglen = sprintf (msg, " %d", ccl_backtrace_table[i]);
1827 if (dst + msglen > (dst_bytes ? dst_end : src))
1828 break;
1829 memcpy (dst, msg, msglen);
1830 dst += msglen;
1831 }
1832 goto ccl_finish;
1833 }
1834 #endif
1835 break;
1836
1837 case CCL_STAT_QUIT:
1838 msglen = ccl->quit_silently ? 0 : sprintf (msg, "\nCCL: Quitted.");
1839 break;
1840
1841 default:
1842 msglen = sprintf (msg, "\nCCL: Unknown error type (%d)", ccl->status);
1843 }
1844
1845 if (msglen <= dst_end - dst)
1846 {
1847 for (i = 0; i < msglen; i++)
1848 *dst++ = msg[i];
1849 }
1850
1851 if (ccl->status == CCL_STAT_INVALID_CMD)
1852 {
1853 #if 0 /* If the remaining bytes contain 0x80..0x9F, copying them
1854 results in an invalid multibyte sequence. */
1855
1856 /* Copy the remaining source data. */
1857 int i = src_end - src;
1858 if (dst_bytes && (dst_end - dst) < i)
1859 i = dst_end - dst;
1860 memcpy (dst, src, i);
1861 src += i;
1862 dst += i;
1863 #else
1864 /* Signal that we've consumed everything. */
1865 src = src_end;
1866 #endif
1867 }
1868 }
1869
1870 ccl_finish:
1871 ccl->ic = ic;
1872 ccl->stack_idx = stack_idx;
1873 ccl->prog = ccl_prog;
1874 ccl->consumed = src - source;
1875 if (dst != NULL)
1876 ccl->produced = dst - destination;
1877 else
1878 ccl->produced = 0;
1879 }
1880
1881 /* Resolve symbols in the specified CCL code (Lisp vector). This
1882 function converts symbols of code conversion maps and character
1883 translation tables embedded in the CCL code into their ID numbers.
1884
1885 The return value is a new vector in which all symbols are resolved,
1886 Qt if resolving of some symbol failed,
1887 or nil if CCL contains invalid data. */
1888
1889 static Lisp_Object
1890 resolve_symbol_ccl_program (Lisp_Object ccl)
1891 {
1892 int i, veclen, unresolved = 0;
1893 Lisp_Object result, contents, val;
1894
1895 if (! (CCL_HEADER_MAIN < ASIZE (ccl) && ASIZE (ccl) <= INT_MAX))
1896 return Qnil;
1897 result = Fcopy_sequence (ccl);
1898 veclen = ASIZE (result);
1899
1900 for (i = 0; i < veclen; i++)
1901 {
1902 contents = AREF (result, i);
1903 if (TYPE_RANGED_FIXNUMP (int, contents))
1904 continue;
1905 else if (CONSP (contents)
1906 && SYMBOLP (XCAR (contents))
1907 && SYMBOLP (XCDR (contents)))
1908 {
1909 /* This is the new style for embedding symbols. The form is
1910 (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
1911 an index number. */
1912 val = Fget (XCAR (contents), XCDR (contents));
1913 if (RANGED_FIXNUMP (0, val, INT_MAX))
1914 ASET (result, i, val);
1915 else
1916 unresolved = 1;
1917 continue;
1918 }
1919 else if (SYMBOLP (contents))
1920 {
1921 /* This is the old style for embedding symbols. This style
1922 may lead to a bug if, for instance, a translation table
1923 and a code conversion map have the same name. */
1924 val = Fget (contents, Qtranslation_table_id);
1925 if (RANGED_FIXNUMP (0, val, INT_MAX))
1926 ASET (result, i, val);
1927 else
1928 {
1929 val = Fget (contents, Qcode_conversion_map_id);
1930 if (RANGED_FIXNUMP (0, val, INT_MAX))
1931 ASET (result, i, val);
1932 else
1933 {
1934 val = Fget (contents, Qccl_program_idx);
1935 if (RANGED_FIXNUMP (0, val, INT_MAX))
1936 ASET (result, i, val);
1937 else
1938 unresolved = 1;
1939 }
1940 }
1941 continue;
1942 }
1943 return Qnil;
1944 }
1945
1946 if (! (0 <= XFIXNUM (AREF (result, CCL_HEADER_BUF_MAG))
1947 && ASCENDING_ORDER (0, XFIXNUM (AREF (result, CCL_HEADER_EOF)),
1948 ASIZE (ccl))))
1949 return Qnil;
1950
1951 return (unresolved ? Qt : result);
1952 }
1953
1954 /* Return the compiled code (vector) of CCL program CCL_PROG.
1955 CCL_PROG is a name (symbol) of the program or already compiled
1956 code. If necessary, resolve symbols in the compiled code to index
1957 numbers. If we failed to get the compiled code or to resolve
1958 symbols, return Qnil. */
1959
1960 static Lisp_Object
1961 ccl_get_compiled_code (Lisp_Object ccl_prog, ptrdiff_t *idx)
1962 {
1963 Lisp_Object val, slot;
1964
1965 if (VECTORP (ccl_prog))
1966 {
1967 val = resolve_symbol_ccl_program (ccl_prog);
1968 *idx = -1;
1969 return (VECTORP (val) ? val : Qnil);
1970 }
1971 if (!SYMBOLP (ccl_prog))
1972 return Qnil;
1973
1974 val = Fget (ccl_prog, Qccl_program_idx);
1975 if (! FIXNATP (val)
1976 || XFIXNUM (val) >= ASIZE (Vccl_program_table))
1977 return Qnil;
1978 slot = AREF (Vccl_program_table, XFIXNUM (val));
1979 if (! VECTORP (slot)
1980 || ASIZE (slot) != 4
1981 || ! VECTORP (AREF (slot, 1)))
1982 return Qnil;
1983 *idx = XFIXNUM (val);
1984 if (NILP (AREF (slot, 2)))
1985 {
1986 val = resolve_symbol_ccl_program (AREF (slot, 1));
1987 if (! VECTORP (val))
1988 return Qnil;
1989 ASET (slot, 1, val);
1990 ASET (slot, 2, Qt);
1991 }
1992 return AREF (slot, 1);
1993 }
1994
1995 /* Setup fields of the structure pointed by CCL appropriately for the
1996 execution of CCL program CCL_PROG. CCL_PROG is the name (symbol)
1997 of the CCL program or the already compiled code (vector).
1998 Return true if successful.
1999
2000 If CCL_PROG is nil, just reset the structure pointed by CCL. */
2001 bool
2002 setup_ccl_program (struct ccl_program *ccl, Lisp_Object ccl_prog)
2003 {
2004 if (! NILP (ccl_prog))
2005 {
2006 struct Lisp_Vector *vp;
2007
2008 ccl_prog = ccl_get_compiled_code (ccl_prog, &ccl->idx);
2009 if (! VECTORP (ccl_prog))
2010 return false;
2011 vp = XVECTOR (ccl_prog);
2012 ccl->size = vp->header.size;
2013 ccl->prog = vp->contents;
2014 ccl->eof_ic = XFIXNUM (vp->contents[CCL_HEADER_EOF]);
2015 ccl->buf_magnification = XFIXNUM (vp->contents[CCL_HEADER_BUF_MAG]);
2016 if (ccl->idx >= 0)
2017 {
2018 Lisp_Object slot;
2019
2020 slot = AREF (Vccl_program_table, ccl->idx);
2021 ASET (slot, 3, Qnil);
2022 }
2023 }
2024 ccl->ic = CCL_HEADER_MAIN;
2025 memset (ccl->reg, 0, sizeof ccl->reg);
2026 ccl->last_block = false;
2027 ccl->status = 0;
2028 ccl->stack_idx = 0;
2029 ccl->quit_silently = false;
2030 return true;
2031 }
2032
2033
2034 DEFUN ("ccl-program-p", Fccl_program_p, Sccl_program_p, 1, 1, 0,
2035 doc: /* Return t if OBJECT is a CCL program name or a compiled CCL program code.
2036 See the documentation of `define-ccl-program' for the detail of CCL program. */)
2037 (Lisp_Object object)
2038 {
2039 Lisp_Object val;
2040
2041 if (VECTORP (object))
2042 {
2043 val = resolve_symbol_ccl_program (object);
2044 return (VECTORP (val) ? Qt : Qnil);
2045 }
2046 if (!SYMBOLP (object))
2047 return Qnil;
2048
2049 val = Fget (object, Qccl_program_idx);
2050 return ((! FIXNATP (val)
2051 || XFIXNUM (val) >= ASIZE (Vccl_program_table))
2052 ? Qnil : Qt);
2053 }
2054
2055 DEFUN ("ccl-execute", Fccl_execute, Sccl_execute, 2, 2, 0,
2056 doc: /* Execute CCL-PROGRAM with registers initialized by REGISTERS.
2057
2058 CCL-PROGRAM is a CCL program name (symbol)
2059 or compiled code generated by `ccl-compile' (for backward compatibility.
2060 In the latter case, the execution overhead is bigger than in the former).
2061 No I/O commands should appear in CCL-PROGRAM.
2062
2063 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value
2064 for the Nth register.
2065
2066 As side effect, each element of REGISTERS holds the value of
2067 the corresponding register after the execution.
2068
2069 See the documentation of `define-ccl-program' for a definition of CCL
2070 programs. */)
2071 (Lisp_Object ccl_prog, Lisp_Object reg)
2072 {
2073 struct ccl_program ccl;
2074 int i;
2075
2076 if (! setup_ccl_program (&ccl, ccl_prog))
2077 error ("Invalid CCL program");
2078
2079 CHECK_VECTOR (reg);
2080 if (ASIZE (reg) != 8)
2081 error ("Length of vector REGISTERS is not 8");
2082
2083 for (i = 0; i < 8; i++)
2084 {
2085 intmax_t n;
2086 ccl.reg[i] = ((INTEGERP (AREF (reg, i))
2087 && integer_to_intmax (AREF (reg, i), &n)
2088 && INT_MIN <= n && n <= INT_MAX)
2089 ? n : 0);
2090 }
2091
2092 ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil);
2093 maybe_quit ();
2094 if (ccl.status != CCL_STAT_SUCCESS)
2095 error ("Error in CCL program at %dth code", ccl.ic);
2096
2097 for (i = 0; i < 8; i++)
2098 ASET (reg, i, make_int (ccl.reg[i]));
2099 return Qnil;
2100 }
2101
2102 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, Sccl_execute_on_string,
2103 3, 5, 0,
2104 doc: /* Execute CCL-PROGRAM with initial STATUS on STRING.
2105
2106 CCL-PROGRAM is a symbol registered by `register-ccl-program',
2107 or a compiled code generated by `ccl-compile' (for backward compatibility,
2108 in this case, the execution is slower).
2109
2110 Read buffer is set to STRING, and write buffer is allocated automatically.
2111
2112 STATUS is a vector of [R0 R1 ... R7 IC], where
2113 R0..R7 are initial values of corresponding registers,
2114 IC is the instruction counter specifying from where to start the program.
2115 If R0..R7 are nil, they are initialized to 0.
2116 If IC is nil, it is initialized to head of the CCL program.
2117
2118 If optional 4th arg CONTINUE is non-nil, keep IC on read operation
2119 when read buffer is exhausted, else, IC is always set to the end of
2120 CCL-PROGRAM on exit.
2121
2122 It returns the contents of write buffer as a string,
2123 and as side effect, STATUS is updated.
2124 If the optional 5th arg UNIBYTE-P is non-nil, the returned string
2125 is a unibyte string. By default it is a multibyte string.
2126
2127 See the documentation of `define-ccl-program' for the detail of CCL program.
2128 usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBYTE-P) */)
2129 (Lisp_Object ccl_prog, Lisp_Object status, Lisp_Object str, Lisp_Object contin, Lisp_Object unibyte_p)
2130 {
2131 Lisp_Object val;
2132 struct ccl_program ccl;
2133 int i;
2134 ptrdiff_t outbufsize;
2135 unsigned char *outbuf, *outp;
2136 ptrdiff_t str_chars, str_bytes;
2137 #define CCL_EXECUTE_BUF_SIZE 1024
2138 int source[CCL_EXECUTE_BUF_SIZE], destination[CCL_EXECUTE_BUF_SIZE];
2139 ptrdiff_t consumed_chars, consumed_bytes, produced_chars;
2140 int buf_magnification;
2141
2142 if (! setup_ccl_program (&ccl, ccl_prog))
2143 error ("Invalid CCL program");
2144
2145 CHECK_VECTOR (status);
2146 if (ASIZE (status) != 9)
2147 error ("Length of vector STATUS is not 9");
2148 CHECK_STRING (str);
2149
2150 str_chars = SCHARS (str);
2151 str_bytes = SBYTES (str);
2152
2153 for (i = 0; i < 8; i++)
2154 {
2155 if (NILP (AREF (status, i)))
2156 ASET (status, i, make_fixnum (0));
2157 intmax_t n;
2158 if (INTEGERP (AREF (status, i))
2159 && integer_to_intmax (AREF (status, i), &n)
2160 && INT_MIN <= n && n <= INT_MAX)
2161 ccl.reg[i] = n;
2162 }
2163 intmax_t ic;
2164 if (INTEGERP (AREF (status, 8)) && integer_to_intmax (AREF (status, 8), &ic))
2165 {
2166 if (ccl.ic < ic && ic < ccl.size)
2167 ccl.ic = ic;
2168 }
2169
2170 buf_magnification = ccl.buf_magnification ? ccl.buf_magnification : 1;
2171 outbufsize = str_bytes;
2172 if (ckd_mul (&outbufsize, outbufsize, buf_magnification)
2173 || ckd_add (&outbufsize, outbufsize, 256))
2174 memory_full (SIZE_MAX);
2175 outp = outbuf = xmalloc (outbufsize);
2176
2177 consumed_chars = consumed_bytes = 0;
2178 produced_chars = 0;
2179 while (1)
2180 {
2181 const unsigned char *p = SDATA (str) + consumed_bytes;
2182 const unsigned char *endp = SDATA (str) + str_bytes;
2183 int j = 0;
2184 int *src, src_size;
2185
2186 if (endp - p == str_chars - consumed_chars)
2187 while (j < CCL_EXECUTE_BUF_SIZE && p < endp)
2188 source[j++] = *p++;
2189 else
2190 while (j < CCL_EXECUTE_BUF_SIZE && p < endp)
2191 source[j++] = string_char_advance (&p);
2192 consumed_chars += j;
2193 consumed_bytes = p - SDATA (str);
2194
2195 if (consumed_bytes == str_bytes)
2196 ccl.last_block = NILP (contin);
2197 src = source;
2198 src_size = j;
2199 while (1)
2200 {
2201 int max_expansion = NILP (unibyte_p) ? MAX_MULTIBYTE_LENGTH : 1;
2202 ptrdiff_t offset, shortfall;
2203 ccl_driver (&ccl, src, destination, src_size, CCL_EXECUTE_BUF_SIZE,
2204 Qnil);
2205 produced_chars += ccl.produced;
2206 offset = outp - outbuf;
2207 shortfall = ccl.produced * max_expansion - (outbufsize - offset);
2208 if (shortfall > 0)
2209 {
2210 outbuf = xpalloc (outbuf, &outbufsize, shortfall, -1, 1);
2211 outp = outbuf + offset;
2212 }
2213 if (NILP (unibyte_p))
2214 {
2215 for (j = 0; j < ccl.produced; j++)
2216 outp += CHAR_STRING (destination[j], outp);
2217 }
2218 else
2219 {
2220 for (j = 0; j < ccl.produced; j++)
2221 *outp++ = destination[j];
2222 }
2223 src += ccl.consumed;
2224 src_size -= ccl.consumed;
2225 if (ccl.status != CCL_STAT_SUSPEND_BY_DST)
2226 break;
2227 }
2228
2229 if (ccl.status != CCL_STAT_SUSPEND_BY_SRC
2230 || str_chars == consumed_chars)
2231 break;
2232 }
2233
2234 if (ccl.status == CCL_STAT_INVALID_CMD)
2235 error ("Error in CCL program at %dth code", ccl.ic);
2236 if (ccl.status == CCL_STAT_QUIT)
2237 error ("CCL program interrupted at %dth code", ccl.ic);
2238
2239 for (i = 0; i < 8; i++)
2240 ASET (status, i, make_int (ccl.reg[i]));
2241 ASET (status, 8, make_int (ccl.ic));
2242
2243 val = make_specified_string ((const char *) outbuf, produced_chars,
2244 outp - outbuf, NILP (unibyte_p));
2245 xfree (outbuf);
2246
2247 return val;
2248 }
2249
2250 DEFUN ("register-ccl-program", Fregister_ccl_program, Sregister_ccl_program,
2251 2, 2, 0,
2252 doc: /* Register CCL program CCL-PROG as NAME in `ccl-program-table'.
2253 CCL-PROG should be a compiled CCL program (vector), or nil.
2254 If it is nil, just reserve NAME as a CCL program name.
2255 Return index number of the registered CCL program. */)
2256 (Lisp_Object name, Lisp_Object ccl_prog)
2257 {
2258 ptrdiff_t len = ASIZE (Vccl_program_table);
2259 ptrdiff_t idx;
2260 Lisp_Object resolved;
2261
2262 CHECK_SYMBOL (name);
2263 resolved = Qnil;
2264 if (!NILP (ccl_prog))
2265 {
2266 CHECK_VECTOR (ccl_prog);
2267 resolved = resolve_symbol_ccl_program (ccl_prog);
2268 if (NILP (resolved))
2269 error ("Error in CCL program");
2270 if (VECTORP (resolved))
2271 {
2272 ccl_prog = resolved;
2273 resolved = Qt;
2274 }
2275 else
2276 resolved = Qnil;
2277 }
2278
2279 for (idx = 0; idx < len; idx++)
2280 {
2281 Lisp_Object slot;
2282
2283 slot = AREF (Vccl_program_table, idx);
2284 if (!VECTORP (slot))
2285 /* This is the first unused slot. Register NAME here. */
2286 break;
2287
2288 if (EQ (name, AREF (slot, 0)))
2289 {
2290 /* Update this slot. */
2291 ASET (slot, 1, ccl_prog);
2292 ASET (slot, 2, resolved);
2293 ASET (slot, 3, Qt);
2294 return make_fixnum (idx);
2295 }
2296 }
2297
2298 if (idx == len)
2299 /* Extend the table. */
2300 Vccl_program_table = larger_vector (Vccl_program_table, 1, -1);
2301
2302 ASET (Vccl_program_table, idx,
2303 CALLN (Fvector, name, ccl_prog, resolved, Qt));
2304
2305 Fput (name, Qccl_program_idx, make_fixnum (idx));
2306 return make_fixnum (idx);
2307 }
2308
2309 /* Register code conversion map.
2310 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
2311 The first element is the start code point.
2312 The other elements are mapped numbers.
2313 Symbol t means to map to an original number before mapping.
2314 Symbol nil means that the corresponding element is empty.
2315 Symbol lambda means to terminate mapping here.
2316 */
2317
2318 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map,
2319 Sregister_code_conversion_map,
2320 2, 2, 0,
2321 doc: /* Register SYMBOL as code conversion map MAP.
2322 Return index number of the registered map. */)
2323 (Lisp_Object symbol, Lisp_Object map)
2324 {
2325 ptrdiff_t len;
2326 ptrdiff_t i;
2327 Lisp_Object idx;
2328
2329 CHECK_SYMBOL (symbol);
2330 CHECK_VECTOR (map);
2331 if (! VECTORP (Vcode_conversion_map_vector))
2332 error ("Invalid code-conversion-map-vector");
2333
2334 len = ASIZE (Vcode_conversion_map_vector);
2335
2336 for (i = 0; i < len; i++)
2337 {
2338 Lisp_Object slot = AREF (Vcode_conversion_map_vector, i);
2339
2340 if (!CONSP (slot))
2341 break;
2342
2343 if (EQ (symbol, XCAR (slot)))
2344 {
2345 idx = make_fixnum (i);
2346 XSETCDR (slot, map);
2347 Fput (symbol, Qcode_conversion_map, map);
2348 Fput (symbol, Qcode_conversion_map_id, idx);
2349 return idx;
2350 }
2351 }
2352
2353 if (i == len)
2354 Vcode_conversion_map_vector = larger_vector (Vcode_conversion_map_vector,
2355 1, -1);
2356
2357 idx = make_fixnum (i);
2358 Fput (symbol, Qcode_conversion_map, map);
2359 Fput (symbol, Qcode_conversion_map_id, idx);
2360 ASET (Vcode_conversion_map_vector, i, Fcons (symbol, map));
2361 return idx;
2362 }
2363
2364
2365 void
2366 syms_of_ccl (void)
2367 {
2368 staticpro (&Vccl_program_table);
2369 Vccl_program_table = make_nil_vector (32);
2370
2371 DEFSYM (Qccl, "ccl");
2372 DEFSYM (Qcclp, "cclp");
2373
2374 /* Symbols of ccl program have this property, a value of the property
2375 is an index for Vccl_program_table. */
2376 DEFSYM (Qccl_program_idx, "ccl-program-idx");
2377
2378 /* These symbols are properties which associate with code conversion
2379 map and their ID respectively. */
2380 DEFSYM (Qcode_conversion_map, "code-conversion-map");
2381 DEFSYM (Qcode_conversion_map_id, "code-conversion-map-id");
2382
2383 DEFVAR_LISP ("code-conversion-map-vector", Vcode_conversion_map_vector,
2384 doc: /* Vector of code conversion maps. */);
2385 Vcode_conversion_map_vector = make_nil_vector (16);
2386
2387 DEFVAR_LISP ("font-ccl-encoder-alist", Vfont_ccl_encoder_alist,
2388 doc: /* Alist of fontname patterns vs corresponding CCL program.
2389 Each element looks like (REGEXP . CCL-CODE),
2390 where CCL-CODE is a compiled CCL program.
2391 When a font whose name matches REGEXP is used for displaying a character,
2392 CCL-CODE is executed to calculate the code point in the font
2393 from the charset number and position code(s) of the character which are set
2394 in CCL registers R0, R1, and R2 before the execution.
2395 The code point in the font is set in CCL registers R1 and R2
2396 when the execution terminated.
2397 If the font is single-byte font, the register R2 is not used. */);
2398 Vfont_ccl_encoder_alist = Qnil;
2399
2400 DEFVAR_LISP ("translation-hash-table-vector", Vtranslation_hash_table_vector,
2401 doc: /* Vector containing all translation hash tables ever defined.
2402 Comprises pairs (SYMBOL . TABLE) where SYMBOL and TABLE were set up by calls
2403 to `define-translation-hash-table'. The vector is indexed by the table id
2404 used by CCL. */);
2405 Vtranslation_hash_table_vector = Qnil;
2406
2407 defsubr (&Sccl_program_p);
2408 defsubr (&Sccl_execute);
2409 defsubr (&Sccl_execute_on_string);
2410 defsubr (&Sregister_ccl_program);
2411 defsubr (&Sregister_code_conversion_map);
2412 }