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