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