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