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