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