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