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