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