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