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