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