HCoop / bpt / emacs.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Convert (most) functions in src to standard C.
[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 Free Software Foundation, Inc.
4 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
5 2005, 2006, 2007, 2008, 2009, 2010
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 associates 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 (struct ccl_program *ccl, int *source, int *destination, int src_size, int dst_size, Lisp_Object charset_list)
866 {
867 register int *reg = ccl->reg;
868 register int ic = ccl->ic;
869 register int code = 0, field1, field2;
870 register Lisp_Object *ccl_prog = ccl->prog;
871 int *src = source, *src_end = src + src_size;
872 int *dst = destination, *dst_end = dst + dst_size;
873 int jump_address;
874 int i = 0, j, op;
875 int stack_idx = ccl->stack_idx;
876 /* Instruction counter of the current CCL code. */
877 int this_ic = 0;
878 struct charset *charset;
879 int eof_ic = ccl->eof_ic;
880 int eof_hit = 0;
881
882 if (ccl->buf_magnification == 0) /* We can't read/produce any bytes. */
883 dst = NULL;
884
885 /* Set mapping stack pointer. */
886 mapping_stack_pointer = mapping_stack;
887
888 #ifdef CCL_DEBUG
889 ccl_backtrace_idx = 0;
890 #endif
891
892 for (;;)
893 {
894 ccl_repeat:
895 #ifdef CCL_DEBUG
896 ccl_backtrace_table[ccl_backtrace_idx++] = ic;
897 if (ccl_backtrace_idx >= CCL_DEBUG_BACKTRACE_LEN)
898 ccl_backtrace_idx = 0;
899 ccl_backtrace_table[ccl_backtrace_idx] = 0;
900 #endif
901
902 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
903 {
904 /* We can't just signal Qquit, instead break the loop as if
905 the whole data is processed. Don't reset Vquit_flag, it
906 must be handled later at a safer place. */
907 if (src)
908 src = source + src_size;
909 ccl->status = CCL_STAT_QUIT;
910 break;
911 }
912
913 this_ic = ic;
914 code = XINT (ccl_prog[ic]); ic++;
915 field1 = code >> 8;
916 field2 = (code & 0xFF) >> 5;
917
918 #define rrr field2
919 #define RRR (field1 & 7)
920 #define Rrr ((field1 >> 3) & 7)
921 #define ADDR field1
922 #define EXCMD (field1 >> 6)
923
924 switch (code & 0x1F)
925 {
926 case CCL_SetRegister: /* 00000000000000000RRRrrrXXXXX */
927 reg[rrr] = reg[RRR];
928 break;
929
930 case CCL_SetShortConst: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
931 reg[rrr] = field1;
932 break;
933
934 case CCL_SetConst: /* 00000000000000000000rrrXXXXX */
935 reg[rrr] = XINT (ccl_prog[ic]);
936 ic++;
937 break;
938
939 case CCL_SetArray: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
940 i = reg[RRR];
941 j = field1 >> 3;
942 if ((unsigned int) i < j)
943 reg[rrr] = XINT (ccl_prog[ic + i]);
944 ic += j;
945 break;
946
947 case CCL_Jump: /* A--D--D--R--E--S--S-000XXXXX */
948 ic += ADDR;
949 break;
950
951 case CCL_JumpCond: /* A--D--D--R--E--S--S-rrrXXXXX */
952 if (!reg[rrr])
953 ic += ADDR;
954 break;
955
956 case CCL_WriteRegisterJump: /* A--D--D--R--E--S--S-rrrXXXXX */
957 i = reg[rrr];
958 CCL_WRITE_CHAR (i);
959 ic += ADDR;
960 break;
961
962 case CCL_WriteRegisterReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
963 i = reg[rrr];
964 CCL_WRITE_CHAR (i);
965 ic++;
966 CCL_READ_CHAR (reg[rrr]);
967 ic += ADDR - 1;
968 break;
969
970 case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */
971 i = XINT (ccl_prog[ic]);
972 CCL_WRITE_CHAR (i);
973 ic += ADDR;
974 break;
975
976 case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
977 i = XINT (ccl_prog[ic]);
978 CCL_WRITE_CHAR (i);
979 ic++;
980 CCL_READ_CHAR (reg[rrr]);
981 ic += ADDR - 1;
982 break;
983
984 case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */
985 j = XINT (ccl_prog[ic]);
986 ic++;
987 CCL_WRITE_STRING (j);
988 ic += ADDR - 1;
989 break;
990
991 case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
992 i = reg[rrr];
993 j = XINT (ccl_prog[ic]);
994 if ((unsigned int) i < j)
995 {
996 i = XINT (ccl_prog[ic + 1 + i]);
997 CCL_WRITE_CHAR (i);
998 }
999 ic += j + 2;
1000 CCL_READ_CHAR (reg[rrr]);
1001 ic += ADDR - (j + 2);
1002 break;
1003
1004 case CCL_ReadJump: /* A--D--D--R--E--S--S-rrrYYYYY */
1005 CCL_READ_CHAR (reg[rrr]);
1006 ic += ADDR;
1007 break;
1008
1009 case CCL_ReadBranch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1010 CCL_READ_CHAR (reg[rrr]);
1011 /* fall through ... */
1012 case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1013 if ((unsigned int) reg[rrr] < field1)
1014 ic += XINT (ccl_prog[ic + reg[rrr]]);
1015 else
1016 ic += XINT (ccl_prog[ic + field1]);
1017 break;
1018
1019 case CCL_ReadRegister: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
1020 while (1)
1021 {
1022 CCL_READ_CHAR (reg[rrr]);
1023 if (!field1) break;
1024 code = XINT (ccl_prog[ic]); ic++;
1025 field1 = code >> 8;
1026 field2 = (code & 0xFF) >> 5;
1027 }
1028 break;
1029
1030 case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */
1031 rrr = 7;
1032 i = reg[RRR];
1033 j = XINT (ccl_prog[ic]);
1034 op = field1 >> 6;
1035 jump_address = ic + 1;
1036 goto ccl_set_expr;
1037
1038 case CCL_WriteRegister: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
1039 while (1)
1040 {
1041 i = reg[rrr];
1042 CCL_WRITE_CHAR (i);
1043 if (!field1) break;
1044 code = XINT (ccl_prog[ic]); ic++;
1045 field1 = code >> 8;
1046 field2 = (code & 0xFF) >> 5;
1047 }
1048 break;
1049
1050 case CCL_WriteExprRegister: /* 1:00000OPERATIONRrrRRR000XXXXX */
1051 rrr = 7;
1052 i = reg[RRR];
1053 j = reg[Rrr];
1054 op = field1 >> 6;
1055 jump_address = ic;
1056 goto ccl_set_expr;
1057
1058 case CCL_Call: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
1059 {
1060 Lisp_Object slot;
1061 int prog_id;
1062
1063 /* If FFF is nonzero, the CCL program ID is in the
1064 following code. */
1065 if (rrr)
1066 {
1067 prog_id = XINT (ccl_prog[ic]);
1068 ic++;
1069 }
1070 else
1071 prog_id = field1;
1072
1073 if (stack_idx >= 256
1074 || prog_id < 0
1075 || prog_id >= ASIZE (Vccl_program_table)
1076 || (slot = AREF (Vccl_program_table, prog_id), !VECTORP (slot))
1077 || !VECTORP (AREF (slot, 1)))
1078 {
1079 if (stack_idx > 0)
1080 {
1081 ccl_prog = ccl_prog_stack_struct[0].ccl_prog;
1082 ic = ccl_prog_stack_struct[0].ic;
1083 eof_ic = ccl_prog_stack_struct[0].eof_ic;
1084 }
1085 CCL_INVALID_CMD;
1086 }
1087
1088 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog;
1089 ccl_prog_stack_struct[stack_idx].ic = ic;
1090 ccl_prog_stack_struct[stack_idx].eof_ic = eof_ic;
1091 stack_idx++;
1092 ccl_prog = XVECTOR (AREF (slot, 1))->contents;
1093 ic = CCL_HEADER_MAIN;
1094 eof_ic = XFASTINT (ccl_prog[CCL_HEADER_EOF]);
1095 }
1096 break;
1097
1098 case CCL_WriteConstString: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1099 if (!rrr)
1100 CCL_WRITE_CHAR (field1);
1101 else
1102 {
1103 CCL_WRITE_STRING (field1);
1104 ic += (field1 + 2) / 3;
1105 }
1106 break;
1107
1108 case CCL_WriteArray: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1109 i = reg[rrr];
1110 if ((unsigned int) i < field1)
1111 {
1112 j = XINT (ccl_prog[ic + i]);
1113 CCL_WRITE_CHAR (j);
1114 }
1115 ic += field1;
1116 break;
1117
1118 case CCL_End: /* 0000000000000000000000XXXXX */
1119 if (stack_idx > 0)
1120 {
1121 stack_idx--;
1122 ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog;
1123 ic = ccl_prog_stack_struct[stack_idx].ic;
1124 eof_ic = ccl_prog_stack_struct[stack_idx].eof_ic;
1125 if (eof_hit)
1126 ic = eof_ic;
1127 break;
1128 }
1129 if (src)
1130 src = src_end;
1131 /* ccl->ic should points to this command code again to
1132 suppress further processing. */
1133 ic--;
1134 CCL_SUCCESS;
1135
1136 case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */
1137 i = XINT (ccl_prog[ic]);
1138 ic++;
1139 op = field1 >> 6;
1140 goto ccl_expr_self;
1141
1142 case CCL_ExprSelfReg: /* 00000OPERATION000RRRrrrXXXXX */
1143 i = reg[RRR];
1144 op = field1 >> 6;
1145
1146 ccl_expr_self:
1147 switch (op)
1148 {
1149 case CCL_PLUS: reg[rrr] += i; break;
1150 case CCL_MINUS: reg[rrr] -= i; break;
1151 case CCL_MUL: reg[rrr] *= i; break;
1152 case CCL_DIV: reg[rrr] /= i; break;
1153 case CCL_MOD: reg[rrr] %= i; break;
1154 case CCL_AND: reg[rrr] &= i; break;
1155 case CCL_OR: reg[rrr] |= i; break;
1156 case CCL_XOR: reg[rrr] ^= i; break;
1157 case CCL_LSH: reg[rrr] <<= i; break;
1158 case CCL_RSH: reg[rrr] >>= i; break;
1159 case CCL_LSH8: reg[rrr] <<= 8; reg[rrr] |= i; break;
1160 case CCL_RSH8: reg[7] = reg[rrr] & 0xFF; reg[rrr] >>= 8; break;
1161 case CCL_DIVMOD: reg[7] = reg[rrr] % i; reg[rrr] /= i; break;
1162 case CCL_LS: reg[rrr] = reg[rrr] < i; break;
1163 case CCL_GT: reg[rrr] = reg[rrr] > i; break;
1164 case CCL_EQ: reg[rrr] = reg[rrr] == i; break;
1165 case CCL_LE: reg[rrr] = reg[rrr] <= i; break;
1166 case CCL_GE: reg[rrr] = reg[rrr] >= i; break;
1167 case CCL_NE: reg[rrr] = reg[rrr] != i; break;
1168 default: CCL_INVALID_CMD;
1169 }
1170 break;
1171
1172 case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */
1173 i = reg[RRR];
1174 j = XINT (ccl_prog[ic]);
1175 op = field1 >> 6;
1176 jump_address = ++ic;
1177 goto ccl_set_expr;
1178
1179 case CCL_SetExprReg: /* 00000OPERATIONRrrRRRrrrXXXXX */
1180 i = reg[RRR];
1181 j = reg[Rrr];
1182 op = field1 >> 6;
1183 jump_address = ic;
1184 goto ccl_set_expr;
1185
1186 case CCL_ReadJumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1187 CCL_READ_CHAR (reg[rrr]);
1188 case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1189 i = reg[rrr];
1190 op = XINT (ccl_prog[ic]);
1191 jump_address = ic++ + ADDR;
1192 j = XINT (ccl_prog[ic]);
1193 ic++;
1194 rrr = 7;
1195 goto ccl_set_expr;
1196
1197 case CCL_ReadJumpCondExprReg: /* A--D--D--R--E--S--S-rrrXXXXX */
1198 CCL_READ_CHAR (reg[rrr]);
1199 case CCL_JumpCondExprReg:
1200 i = reg[rrr];
1201 op = XINT (ccl_prog[ic]);
1202 jump_address = ic++ + ADDR;
1203 j = reg[XINT (ccl_prog[ic])];
1204 ic++;
1205 rrr = 7;
1206
1207 ccl_set_expr:
1208 switch (op)
1209 {
1210 case CCL_PLUS: reg[rrr] = i + j; break;
1211 case CCL_MINUS: reg[rrr] = i - j; break;
1212 case CCL_MUL: reg[rrr] = i * j; break;
1213 case CCL_DIV: reg[rrr] = i / j; break;
1214 case CCL_MOD: reg[rrr] = i % j; break;
1215 case CCL_AND: reg[rrr] = i & j; break;
1216 case CCL_OR: reg[rrr] = i | j; break;
1217 case CCL_XOR: reg[rrr] = i ^ j; break;
1218 case CCL_LSH: reg[rrr] = i << j; break;
1219 case CCL_RSH: reg[rrr] = i >> j; break;
1220 case CCL_LSH8: reg[rrr] = (i << 8) | j; break;
1221 case CCL_RSH8: reg[rrr] = i >> 8; reg[7] = i & 0xFF; break;
1222 case CCL_DIVMOD: reg[rrr] = i / j; reg[7] = i % j; break;
1223 case CCL_LS: reg[rrr] = i < j; break;
1224 case CCL_GT: reg[rrr] = i > j; break;
1225 case CCL_EQ: reg[rrr] = i == j; break;
1226 case CCL_LE: reg[rrr] = i <= j; break;
1227 case CCL_GE: reg[rrr] = i >= j; break;
1228 case CCL_NE: reg[rrr] = i != j; break;
1229 case CCL_DECODE_SJIS:
1230 {
1231 i = (i << 8) | j;
1232 SJIS_TO_JIS (i);
1233 reg[rrr] = i >> 8;
1234 reg[7] = i & 0xFF;
1235 break;
1236 }
1237 case CCL_ENCODE_SJIS:
1238 {
1239 i = (i << 8) | j;
1240 JIS_TO_SJIS (i);
1241 reg[rrr] = i >> 8;
1242 reg[7] = i & 0xFF;
1243 break;
1244 }
1245 default: CCL_INVALID_CMD;
1246 }
1247 code &= 0x1F;
1248 if (code == CCL_WriteExprConst || code == CCL_WriteExprRegister)
1249 {
1250 i = reg[rrr];
1251 CCL_WRITE_CHAR (i);
1252 ic = jump_address;
1253 }
1254 else if (!reg[rrr])
1255 ic = jump_address;
1256 break;
1257
1258 case CCL_Extension:
1259 switch (EXCMD)
1260 {
1261 case CCL_ReadMultibyteChar2:
1262 if (!src)
1263 CCL_INVALID_CMD;
1264 CCL_READ_CHAR (i);
1265 CCL_ENCODE_CHAR (i, charset_list, reg[RRR], reg[rrr]);
1266 break;
1267
1268 case CCL_WriteMultibyteChar2:
1269 if (! dst)
1270 CCL_INVALID_CMD;
1271 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1272 CCL_WRITE_CHAR (i);
1273 break;
1274
1275 case CCL_TranslateCharacter:
1276 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1277 op = translate_char (GET_TRANSLATION_TABLE (reg[Rrr]), i);
1278 CCL_ENCODE_CHAR (op, charset_list, reg[RRR], reg[rrr]);
1279 break;
1280
1281 case CCL_TranslateCharacterConstTbl:
1282 op = XINT (ccl_prog[ic]); /* table */
1283 ic++;
1284 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1285 op = translate_char (GET_TRANSLATION_TABLE (op), i);
1286 CCL_ENCODE_CHAR (op, charset_list, reg[RRR], reg[rrr]);
1287 break;
1288
1289 case CCL_LookupIntConstTbl:
1290 op = XINT (ccl_prog[ic]); /* table */
1291 ic++;
1292 {
1293 struct Lisp_Hash_Table *h = GET_HASH_TABLE (op);
1294
1295 op = hash_lookup (h, make_number (reg[RRR]), NULL);
1296 if (op >= 0)
1297 {
1298 Lisp_Object opl;
1299 opl = HASH_VALUE (h, op);
1300 if (! CHARACTERP (opl))
1301 CCL_INVALID_CMD;
1302 reg[RRR] = charset_unicode;
1303 reg[rrr] = op;
1304 reg[7] = 1; /* r7 true for success */
1305 }
1306 else
1307 reg[7] = 0;
1308 }
1309 break;
1310
1311 case CCL_LookupCharConstTbl:
1312 op = XINT (ccl_prog[ic]); /* table */
1313 ic++;
1314 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1315 {
1316 struct Lisp_Hash_Table *h = GET_HASH_TABLE (op);
1317
1318 op = hash_lookup (h, make_number (i), NULL);
1319 if (op >= 0)
1320 {
1321 Lisp_Object opl;
1322 opl = HASH_VALUE (h, op);
1323 if (!INTEGERP (opl))
1324 CCL_INVALID_CMD;
1325 reg[RRR] = XINT (opl);
1326 reg[7] = 1; /* r7 true for success */
1327 }
1328 else
1329 reg[7] = 0;
1330 }
1331 break;
1332
1333 case CCL_IterateMultipleMap:
1334 {
1335 Lisp_Object map, content, attrib, value;
1336 int point, size, fin_ic;
1337
1338 j = XINT (ccl_prog[ic++]); /* number of maps. */
1339 fin_ic = ic + j;
1340 op = reg[rrr];
1341 if ((j > reg[RRR]) && (j >= 0))
1342 {
1343 ic += reg[RRR];
1344 i = reg[RRR];
1345 }
1346 else
1347 {
1348 reg[RRR] = -1;
1349 ic = fin_ic;
1350 break;
1351 }
1352
1353 for (;i < j;i++)
1354 {
1355
1356 size = ASIZE (Vcode_conversion_map_vector);
1357 point = XINT (ccl_prog[ic++]);
1358 if (point >= size) continue;
1359 map = AREF (Vcode_conversion_map_vector, point);
1360
1361 /* Check map validity. */
1362 if (!CONSP (map)) continue;
1363 map = XCDR (map);
1364 if (!VECTORP (map)) continue;
1365 size = ASIZE (map);
1366 if (size <= 1) continue;
1367
1368 content = AREF (map, 0);
1369
1370 /* check map type,
1371 [STARTPOINT VAL1 VAL2 ...] or
1372 [t ELEMENT STARTPOINT ENDPOINT] */
1373 if (NUMBERP (content))
1374 {
1375 point = XUINT (content);
1376 point = op - point + 1;
1377 if (!((point >= 1) && (point < size))) continue;
1378 content = AREF (map, point);
1379 }
1380 else if (EQ (content, Qt))
1381 {
1382 if (size != 4) continue;
1383 if ((op >= XUINT (AREF (map, 2)))
1384 && (op < XUINT (AREF (map, 3))))
1385 content = AREF (map, 1);
1386 else
1387 continue;
1388 }
1389 else
1390 continue;
1391
1392 if (NILP (content))
1393 continue;
1394 else if (NUMBERP (content))
1395 {
1396 reg[RRR] = i;
1397 reg[rrr] = XINT(content);
1398 break;
1399 }
1400 else if (EQ (content, Qt) || EQ (content, Qlambda))
1401 {
1402 reg[RRR] = i;
1403 break;
1404 }
1405 else if (CONSP (content))
1406 {
1407 attrib = XCAR (content);
1408 value = XCDR (content);
1409 if (!NUMBERP (attrib) || !NUMBERP (value))
1410 continue;
1411 reg[RRR] = i;
1412 reg[rrr] = XUINT (value);
1413 break;
1414 }
1415 else if (SYMBOLP (content))
1416 CCL_CALL_FOR_MAP_INSTRUCTION (content, fin_ic);
1417 else
1418 CCL_INVALID_CMD;
1419 }
1420 if (i == j)
1421 reg[RRR] = -1;
1422 ic = fin_ic;
1423 }
1424 break;
1425
1426 case CCL_MapMultiple:
1427 {
1428 Lisp_Object map, content, attrib, value;
1429 int point, size, map_vector_size;
1430 int map_set_rest_length, fin_ic;
1431 int current_ic = this_ic;
1432
1433 /* inhibit recursive call on MapMultiple. */
1434 if (stack_idx_of_map_multiple > 0)
1435 {
1436 if (stack_idx_of_map_multiple <= stack_idx)
1437 {
1438 stack_idx_of_map_multiple = 0;
1439 mapping_stack_pointer = mapping_stack;
1440 CCL_INVALID_CMD;
1441 }
1442 }
1443 else
1444 mapping_stack_pointer = mapping_stack;
1445 stack_idx_of_map_multiple = 0;
1446
1447 map_set_rest_length =
1448 XINT (ccl_prog[ic++]); /* number of maps and separators. */
1449 fin_ic = ic + map_set_rest_length;
1450 op = reg[rrr];
1451
1452 if ((map_set_rest_length > reg[RRR]) && (reg[RRR] >= 0))
1453 {
1454 ic += reg[RRR];
1455 i = reg[RRR];
1456 map_set_rest_length -= i;
1457 }
1458 else
1459 {
1460 ic = fin_ic;
1461 reg[RRR] = -1;
1462 mapping_stack_pointer = mapping_stack;
1463 break;
1464 }
1465
1466 if (mapping_stack_pointer <= (mapping_stack + 1))
1467 {
1468 /* Set up initial state. */
1469 mapping_stack_pointer = mapping_stack;
1470 PUSH_MAPPING_STACK (0, op);
1471 reg[RRR] = -1;
1472 }
1473 else
1474 {
1475 /* Recover after calling other ccl program. */
1476 int orig_op;
1477
1478 POP_MAPPING_STACK (map_set_rest_length, orig_op);
1479 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1480 switch (op)
1481 {
1482 case -1:
1483 /* Regard it as Qnil. */
1484 op = orig_op;
1485 i++;
1486 ic++;
1487 map_set_rest_length--;
1488 break;
1489 case -2:
1490 /* Regard it as Qt. */
1491 op = reg[rrr];
1492 i++;
1493 ic++;
1494 map_set_rest_length--;
1495 break;
1496 case -3:
1497 /* Regard it as Qlambda. */
1498 op = orig_op;
1499 i += map_set_rest_length;
1500 ic += map_set_rest_length;
1501 map_set_rest_length = 0;
1502 break;
1503 default:
1504 /* Regard it as normal mapping. */
1505 i += map_set_rest_length;
1506 ic += map_set_rest_length;
1507 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1508 break;
1509 }
1510 }
1511 map_vector_size = ASIZE (Vcode_conversion_map_vector);
1512
1513 do {
1514 for (;map_set_rest_length > 0;i++, ic++, map_set_rest_length--)
1515 {
1516 point = XINT(ccl_prog[ic]);
1517 if (point < 0)
1518 {
1519 /* +1 is for including separator. */
1520 point = -point + 1;
1521 if (mapping_stack_pointer
1522 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1523 CCL_INVALID_CMD;
1524 PUSH_MAPPING_STACK (map_set_rest_length - point,
1525 reg[rrr]);
1526 map_set_rest_length = point;
1527 reg[rrr] = op;
1528 continue;
1529 }
1530
1531 if (point >= map_vector_size) continue;
1532 map = AREF (Vcode_conversion_map_vector, point);
1533
1534 /* Check map validity. */
1535 if (!CONSP (map)) continue;
1536 map = XCDR (map);
1537 if (!VECTORP (map)) continue;
1538 size = ASIZE (map);
1539 if (size <= 1) continue;
1540
1541 content = AREF (map, 0);
1542
1543 /* check map type,
1544 [STARTPOINT VAL1 VAL2 ...] or
1545 [t ELEMENT STARTPOINT ENDPOINT] */
1546 if (NUMBERP (content))
1547 {
1548 point = XUINT (content);
1549 point = op - point + 1;
1550 if (!((point >= 1) && (point < size))) continue;
1551 content = AREF (map, point);
1552 }
1553 else if (EQ (content, Qt))
1554 {
1555 if (size != 4) continue;
1556 if ((op >= XUINT (AREF (map, 2))) &&
1557 (op < XUINT (AREF (map, 3))))
1558 content = AREF (map, 1);
1559 else
1560 continue;
1561 }
1562 else
1563 continue;
1564
1565 if (NILP (content))
1566 continue;
1567
1568 reg[RRR] = i;
1569 if (NUMBERP (content))
1570 {
1571 op = XINT (content);
1572 i += map_set_rest_length - 1;
1573 ic += map_set_rest_length - 1;
1574 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1575 map_set_rest_length++;
1576 }
1577 else if (CONSP (content))
1578 {
1579 attrib = XCAR (content);
1580 value = XCDR (content);
1581 if (!NUMBERP (attrib) || !NUMBERP (value))
1582 continue;
1583 op = XUINT (value);
1584 i += map_set_rest_length - 1;
1585 ic += map_set_rest_length - 1;
1586 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1587 map_set_rest_length++;
1588 }
1589 else if (EQ (content, Qt))
1590 {
1591 op = reg[rrr];
1592 }
1593 else if (EQ (content, Qlambda))
1594 {
1595 i += map_set_rest_length;
1596 ic += map_set_rest_length;
1597 break;
1598 }
1599 else if (SYMBOLP (content))
1600 {
1601 if (mapping_stack_pointer
1602 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1603 CCL_INVALID_CMD;
1604 PUSH_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1605 PUSH_MAPPING_STACK (map_set_rest_length, op);
1606 stack_idx_of_map_multiple = stack_idx + 1;
1607 CCL_CALL_FOR_MAP_INSTRUCTION (content, current_ic);
1608 }
1609 else
1610 CCL_INVALID_CMD;
1611 }
1612 if (mapping_stack_pointer <= (mapping_stack + 1))
1613 break;
1614 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1615 i += map_set_rest_length;
1616 ic += map_set_rest_length;
1617 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1618 } while (1);
1619
1620 ic = fin_ic;
1621 }
1622 reg[rrr] = op;
1623 break;
1624
1625 case CCL_MapSingle:
1626 {
1627 Lisp_Object map, attrib, value, content;
1628 int size, point;
1629 j = XINT (ccl_prog[ic++]); /* map_id */
1630 op = reg[rrr];
1631 if (j >= ASIZE (Vcode_conversion_map_vector))
1632 {
1633 reg[RRR] = -1;
1634 break;
1635 }
1636 map = AREF (Vcode_conversion_map_vector, j);
1637 if (!CONSP (map))
1638 {
1639 reg[RRR] = -1;
1640 break;
1641 }
1642 map = XCDR (map);
1643 if (!VECTORP (map))
1644 {
1645 reg[RRR] = -1;
1646 break;
1647 }
1648 size = ASIZE (map);
1649 point = XUINT (AREF (map, 0));
1650 point = op - point + 1;
1651 reg[RRR] = 0;
1652 if ((size <= 1) ||
1653 (!((point >= 1) && (point < size))))
1654 reg[RRR] = -1;
1655 else
1656 {
1657 reg[RRR] = 0;
1658 content = AREF (map, point);
1659 if (NILP (content))
1660 reg[RRR] = -1;
1661 else if (NUMBERP (content))
1662 reg[rrr] = XINT (content);
1663 else if (EQ (content, Qt));
1664 else if (CONSP (content))
1665 {
1666 attrib = XCAR (content);
1667 value = XCDR (content);
1668 if (!NUMBERP (attrib) || !NUMBERP (value))
1669 continue;
1670 reg[rrr] = XUINT(value);
1671 break;
1672 }
1673 else if (SYMBOLP (content))
1674 CCL_CALL_FOR_MAP_INSTRUCTION (content, ic);
1675 else
1676 reg[RRR] = -1;
1677 }
1678 }
1679 break;
1680
1681 default:
1682 CCL_INVALID_CMD;
1683 }
1684 break;
1685
1686 default:
1687 CCL_INVALID_CMD;
1688 }
1689 }
1690
1691 ccl_error_handler:
1692 /* The suppress_error member is set when e.g. a CCL-based coding
1693 system is used for terminal output. */
1694 if (!ccl->suppress_error && destination)
1695 {
1696 /* We can insert an error message only if DESTINATION is
1697 specified and we still have a room to store the message
1698 there. */
1699 char msg[256];
1700 int msglen;
1701
1702 if (!dst)
1703 dst = destination;
1704
1705 switch (ccl->status)
1706 {
1707 case CCL_STAT_INVALID_CMD:
1708 sprintf(msg, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1709 code & 0x1F, code, this_ic);
1710 #ifdef CCL_DEBUG
1711 {
1712 int i = ccl_backtrace_idx - 1;
1713 int j;
1714
1715 msglen = strlen (msg);
1716 if (dst + msglen <= (dst_bytes ? dst_end : src))
1717 {
1718 bcopy (msg, dst, msglen);
1719 dst += msglen;
1720 }
1721
1722 for (j = 0; j < CCL_DEBUG_BACKTRACE_LEN; j++, i--)
1723 {
1724 if (i < 0) i = CCL_DEBUG_BACKTRACE_LEN - 1;
1725 if (ccl_backtrace_table[i] == 0)
1726 break;
1727 sprintf(msg, " %d", ccl_backtrace_table[i]);
1728 msglen = strlen (msg);
1729 if (dst + msglen > (dst_bytes ? dst_end : src))
1730 break;
1731 bcopy (msg, dst, msglen);
1732 dst += msglen;
1733 }
1734 goto ccl_finish;
1735 }
1736 #endif
1737 break;
1738
1739 case CCL_STAT_QUIT:
1740 if (! ccl->quit_silently)
1741 sprintf(msg, "\nCCL: Quited.");
1742 break;
1743
1744 default:
1745 sprintf(msg, "\nCCL: Unknown error type (%d)", ccl->status);
1746 }
1747
1748 msglen = strlen (msg);
1749 if (dst + msglen <= dst_end)
1750 {
1751 for (i = 0; i < msglen; i++)
1752 *dst++ = msg[i];
1753 }
1754
1755 if (ccl->status == CCL_STAT_INVALID_CMD)
1756 {
1757 #if 0 /* If the remaining bytes contain 0x80..0x9F, copying them
1758 results in an invalid multibyte sequence. */
1759
1760 /* Copy the remaining source data. */
1761 int i = src_end - src;
1762 if (dst_bytes && (dst_end - dst) < i)
1763 i = dst_end - dst;
1764 bcopy (src, dst, i);
1765 src += i;
1766 dst += i;
1767 #else
1768 /* Signal that we've consumed everything. */
1769 src = src_end;
1770 #endif
1771 }
1772 }
1773
1774 ccl_finish:
1775 ccl->ic = ic;
1776 ccl->stack_idx = stack_idx;
1777 ccl->prog = ccl_prog;
1778 ccl->consumed = src - source;
1779 if (dst != NULL)
1780 ccl->produced = dst - destination;
1781 else
1782 ccl->produced = 0;
1783 }
1784
1785 /* Resolve symbols in the specified CCL code (Lisp vector). This
1786 function converts symbols of code conversion maps and character
1787 translation tables embeded in the CCL code into their ID numbers.
1788
1789 The return value is a vector (CCL itself or a new vector in which
1790 all symbols are resolved), Qt if resolving of some symbol failed,
1791 or nil if CCL contains invalid data. */
1792
1793 static Lisp_Object
1794 resolve_symbol_ccl_program (Lisp_Object ccl)
1795 {
1796 int i, veclen, unresolved = 0;
1797 Lisp_Object result, contents, val;
1798
1799 result = ccl;
1800 veclen = ASIZE (result);
1801
1802 for (i = 0; i < veclen; i++)
1803 {
1804 contents = AREF (result, i);
1805 if (INTEGERP (contents))
1806 continue;
1807 else if (CONSP (contents)
1808 && SYMBOLP (XCAR (contents))
1809 && SYMBOLP (XCDR (contents)))
1810 {
1811 /* This is the new style for embedding symbols. The form is
1812 (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
1813 an index number. */
1814
1815 if (EQ (result, ccl))
1816 result = Fcopy_sequence (ccl);
1817
1818 val = Fget (XCAR (contents), XCDR (contents));
1819 if (NATNUMP (val))
1820 ASET (result, i, val);
1821 else
1822 unresolved = 1;
1823 continue;
1824 }
1825 else if (SYMBOLP (contents))
1826 {
1827 /* This is the old style for embedding symbols. This style
1828 may lead to a bug if, for instance, a translation table
1829 and a code conversion map have the same name. */
1830 if (EQ (result, ccl))
1831 result = Fcopy_sequence (ccl);
1832
1833 val = Fget (contents, Qtranslation_table_id);
1834 if (NATNUMP (val))
1835 ASET (result, i, val);
1836 else
1837 {
1838 val = Fget (contents, Qcode_conversion_map_id);
1839 if (NATNUMP (val))
1840 ASET (result, i, val);
1841 else
1842 {
1843 val = Fget (contents, Qccl_program_idx);
1844 if (NATNUMP (val))
1845 ASET (result, i, val);
1846 else
1847 unresolved = 1;
1848 }
1849 }
1850 continue;
1851 }
1852 return Qnil;
1853 }
1854
1855 return (unresolved ? Qt : result);
1856 }
1857
1858 /* Return the compiled code (vector) of CCL program CCL_PROG.
1859 CCL_PROG is a name (symbol) of the program or already compiled
1860 code. If necessary, resolve symbols in the compiled code to index
1861 numbers. If we failed to get the compiled code or to resolve
1862 symbols, return Qnil. */
1863
1864 static Lisp_Object
1865 ccl_get_compiled_code (Lisp_Object ccl_prog, int *idx)
1866 {
1867 Lisp_Object val, slot;
1868
1869 if (VECTORP (ccl_prog))
1870 {
1871 val = resolve_symbol_ccl_program (ccl_prog);
1872 *idx = -1;
1873 return (VECTORP (val) ? val : Qnil);
1874 }
1875 if (!SYMBOLP (ccl_prog))
1876 return Qnil;
1877
1878 val = Fget (ccl_prog, Qccl_program_idx);
1879 if (! NATNUMP (val)
1880 || XINT (val) >= ASIZE (Vccl_program_table))
1881 return Qnil;
1882 slot = AREF (Vccl_program_table, XINT (val));
1883 if (! VECTORP (slot)
1884 || ASIZE (slot) != 4
1885 || ! VECTORP (AREF (slot, 1)))
1886 return Qnil;
1887 *idx = XINT (val);
1888 if (NILP (AREF (slot, 2)))
1889 {
1890 val = resolve_symbol_ccl_program (AREF (slot, 1));
1891 if (! VECTORP (val))
1892 return Qnil;
1893 ASET (slot, 1, val);
1894 ASET (slot, 2, Qt);
1895 }
1896 return AREF (slot, 1);
1897 }
1898
1899 /* Setup fields of the structure pointed by CCL appropriately for the
1900 execution of CCL program CCL_PROG. CCL_PROG is the name (symbol)
1901 of the CCL program or the already compiled code (vector).
1902 Return 0 if we succeed this setup, else return -1.
1903
1904 If CCL_PROG is nil, we just reset the structure pointed by CCL. */
1905 int
1906 setup_ccl_program (struct ccl_program *ccl, Lisp_Object ccl_prog)
1907 {
1908 int i;
1909
1910 if (! NILP (ccl_prog))
1911 {
1912 struct Lisp_Vector *vp;
1913
1914 ccl_prog = ccl_get_compiled_code (ccl_prog, &ccl->idx);
1915 if (! VECTORP (ccl_prog))
1916 return -1;
1917 vp = XVECTOR (ccl_prog);
1918 ccl->size = vp->size;
1919 ccl->prog = vp->contents;
1920 ccl->eof_ic = XINT (vp->contents[CCL_HEADER_EOF]);
1921 ccl->buf_magnification = XINT (vp->contents[CCL_HEADER_BUF_MAG]);
1922 if (ccl->idx >= 0)
1923 {
1924 Lisp_Object slot;
1925
1926 slot = AREF (Vccl_program_table, ccl->idx);
1927 ASET (slot, 3, Qnil);
1928 }
1929 }
1930 ccl->ic = CCL_HEADER_MAIN;
1931 for (i = 0; i < 8; i++)
1932 ccl->reg[i] = 0;
1933 ccl->last_block = 0;
1934 ccl->private_state = 0;
1935 ccl->status = 0;
1936 ccl->stack_idx = 0;
1937 ccl->suppress_error = 0;
1938 ccl->eight_bit_control = 0;
1939 ccl->quit_silently = 0;
1940 return 0;
1941 }
1942
1943
1944 /* Check if CCL is updated or not. If not, re-setup members of CCL. */
1945
1946 int
1947 check_ccl_update (struct ccl_program *ccl)
1948 {
1949 Lisp_Object slot, ccl_prog;
1950
1951 if (ccl->idx < 0)
1952 return 0;
1953 slot = AREF (Vccl_program_table, ccl->idx);
1954 if (NILP (AREF (slot, 3)))
1955 return 0;
1956 ccl_prog = ccl_get_compiled_code (AREF (slot, 0), &ccl->idx);
1957 if (! VECTORP (ccl_prog))
1958 return -1;
1959 ccl->size = ASIZE (ccl_prog);
1960 ccl->prog = XVECTOR (ccl_prog)->contents;
1961 ccl->eof_ic = XINT (AREF (ccl_prog, CCL_HEADER_EOF));
1962 ccl->buf_magnification = XINT (AREF (ccl_prog, CCL_HEADER_BUF_MAG));
1963 ASET (slot, 3, Qnil);
1964 return 0;
1965 }
1966
1967
1968 DEFUN ("ccl-program-p", Fccl_program_p, Sccl_program_p, 1, 1, 0,
1969 doc: /* Return t if OBJECT is a CCL program name or a compiled CCL program code.
1970 See the documentation of `define-ccl-program' for the detail of CCL program. */)
1971 (object)
1972 Lisp_Object object;
1973 {
1974 Lisp_Object val;
1975
1976 if (VECTORP (object))
1977 {
1978 val = resolve_symbol_ccl_program (object);
1979 return (VECTORP (val) ? Qt : Qnil);
1980 }
1981 if (!SYMBOLP (object))
1982 return Qnil;
1983
1984 val = Fget (object, Qccl_program_idx);
1985 return ((! NATNUMP (val)
1986 || XINT (val) >= ASIZE (Vccl_program_table))
1987 ? Qnil : Qt);
1988 }
1989
1990 DEFUN ("ccl-execute", Fccl_execute, Sccl_execute, 2, 2, 0,
1991 doc: /* Execute CCL-PROGRAM with registers initialized by REGISTERS.
1992
1993 CCL-PROGRAM is a CCL program name (symbol)
1994 or compiled code generated by `ccl-compile' (for backward compatibility.
1995 In the latter case, the execution overhead is bigger than in the former).
1996 No I/O commands should appear in CCL-PROGRAM.
1997
1998 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value
1999 for the Nth register.
2000
2001 As side effect, each element of REGISTERS holds the value of
2002 the corresponding register after the execution.
2003
2004 See the documentation of `define-ccl-program' for a definition of CCL
2005 programs. */)
2006 (ccl_prog, reg)
2007 Lisp_Object ccl_prog, reg;
2008 {
2009 struct ccl_program ccl;
2010 int i;
2011
2012 if (setup_ccl_program (&ccl, ccl_prog) < 0)
2013 error ("Invalid CCL program");
2014
2015 CHECK_VECTOR (reg);
2016 if (ASIZE (reg) != 8)
2017 error ("Length of vector REGISTERS is not 8");
2018
2019 for (i = 0; i < 8; i++)
2020 ccl.reg[i] = (INTEGERP (AREF (reg, i))
2021 ? XINT (AREF (reg, i))
2022 : 0);
2023
2024 ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil);
2025 QUIT;
2026 if (ccl.status != CCL_STAT_SUCCESS)
2027 error ("Error in CCL program at %dth code", ccl.ic);
2028
2029 for (i = 0; i < 8; i++)
2030 ASET (reg, i, make_number (ccl.reg[i]));
2031 return Qnil;
2032 }
2033
2034 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, Sccl_execute_on_string,
2035 3, 5, 0,
2036 doc: /* Execute CCL-PROGRAM with initial STATUS on STRING.
2037
2038 CCL-PROGRAM is a symbol registered by `register-ccl-program',
2039 or a compiled code generated by `ccl-compile' (for backward compatibility,
2040 in this case, the execution is slower).
2041
2042 Read buffer is set to STRING, and write buffer is allocated automatically.
2043
2044 STATUS is a vector of [R0 R1 ... R7 IC], where
2045 R0..R7 are initial values of corresponding registers,
2046 IC is the instruction counter specifying from where to start the program.
2047 If R0..R7 are nil, they are initialized to 0.
2048 If IC is nil, it is initialized to head of the CCL program.
2049
2050 If optional 4th arg CONTINUE is non-nil, keep IC on read operation
2051 when read buffer is exausted, else, IC is always set to the end of
2052 CCL-PROGRAM on exit.
2053
2054 It returns the contents of write buffer as a string,
2055 and as side effect, STATUS is updated.
2056 If the optional 5th arg UNIBYTE-P is non-nil, the returned string
2057 is a unibyte string. By default it is a multibyte string.
2058
2059 See the documentation of `define-ccl-program' for the detail of CCL program.
2060 usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBYTE-P) */)
2061 (ccl_prog, status, str, contin, unibyte_p)
2062 Lisp_Object ccl_prog, status, str, contin, unibyte_p;
2063 {
2064 Lisp_Object val;
2065 struct ccl_program ccl;
2066 int i;
2067 int outbufsize;
2068 unsigned char *outbuf, *outp;
2069 int str_chars, str_bytes;
2070 #define CCL_EXECUTE_BUF_SIZE 1024
2071 int source[CCL_EXECUTE_BUF_SIZE], destination[CCL_EXECUTE_BUF_SIZE];
2072 int consumed_chars, consumed_bytes, produced_chars;
2073
2074 if (setup_ccl_program (&ccl, ccl_prog) < 0)
2075 error ("Invalid CCL program");
2076
2077 CHECK_VECTOR (status);
2078 if (ASIZE (status) != 9)
2079 error ("Length of vector STATUS is not 9");
2080 CHECK_STRING (str);
2081
2082 str_chars = SCHARS (str);
2083 str_bytes = SBYTES (str);
2084
2085 for (i = 0; i < 8; i++)
2086 {
2087 if (NILP (AREF (status, i)))
2088 ASET (status, i, make_number (0));
2089 if (INTEGERP (AREF (status, i)))
2090 ccl.reg[i] = XINT (AREF (status, i));
2091 }
2092 if (INTEGERP (AREF (status, i)))
2093 {
2094 i = XFASTINT (AREF (status, 8));
2095 if (ccl.ic < i && i < ccl.size)
2096 ccl.ic = i;
2097 }
2098
2099 outbufsize = (ccl.buf_magnification
2100 ? str_bytes * ccl.buf_magnification + 256
2101 : str_bytes + 256);
2102 outp = outbuf = (unsigned char *) xmalloc (outbufsize);
2103
2104 consumed_chars = consumed_bytes = 0;
2105 produced_chars = 0;
2106 while (1)
2107 {
2108 const unsigned char *p = SDATA (str) + consumed_bytes;
2109 const unsigned char *endp = SDATA (str) + str_bytes;
2110 int i = 0;
2111 int *src, src_size;
2112
2113 if (endp - p == str_chars - consumed_chars)
2114 while (i < CCL_EXECUTE_BUF_SIZE && p < endp)
2115 source[i++] = *p++;
2116 else
2117 while (i < CCL_EXECUTE_BUF_SIZE && p < endp)
2118 source[i++] = STRING_CHAR_ADVANCE (p);
2119 consumed_chars += i;
2120 consumed_bytes = p - SDATA (str);
2121
2122 if (consumed_bytes == str_bytes)
2123 ccl.last_block = NILP (contin);
2124 src = source;
2125 src_size = i;
2126 while (1)
2127 {
2128 ccl_driver (&ccl, src, destination, src_size, CCL_EXECUTE_BUF_SIZE,
2129 Qnil);
2130 produced_chars += ccl.produced;
2131 if (NILP (unibyte_p))
2132 {
2133 if (outp - outbuf + MAX_MULTIBYTE_LENGTH * ccl.produced
2134 > outbufsize)
2135 {
2136 int offset = outp - outbuf;
2137 outbufsize += MAX_MULTIBYTE_LENGTH * ccl.produced;
2138 outbuf = (unsigned char *) xrealloc (outbuf, outbufsize);
2139 outp = outbuf + offset;
2140 }
2141 for (i = 0; i < ccl.produced; i++)
2142 CHAR_STRING_ADVANCE (destination[i], outp);
2143 }
2144 else
2145 {
2146 if (outp - outbuf + ccl.produced > outbufsize)
2147 {
2148 int offset = outp - outbuf;
2149 outbufsize += ccl.produced;
2150 outbuf = (unsigned char *) xrealloc (outbuf, outbufsize);
2151 outp = outbuf + offset;
2152 }
2153 for (i = 0; i < ccl.produced; i++)
2154 *outp++ = destination[i];
2155 }
2156 src += ccl.consumed;
2157 src_size -= ccl.consumed;
2158 if (ccl.status != CCL_STAT_SUSPEND_BY_DST)
2159 break;
2160 }
2161
2162 if (ccl.status != CCL_STAT_SUSPEND_BY_SRC
2163 || str_chars == consumed_chars)
2164 break;
2165 }
2166
2167 if (ccl.status == CCL_STAT_INVALID_CMD)
2168 error ("Error in CCL program at %dth code", ccl.ic);
2169 if (ccl.status == CCL_STAT_QUIT)
2170 error ("CCL program interrupted at %dth code", ccl.ic);
2171
2172 for (i = 0; i < 8; i++)
2173 ASET (status, i, make_number (ccl.reg[i]));
2174 ASET (status, 8, make_number (ccl.ic));
2175
2176 if (NILP (unibyte_p))
2177 val = make_multibyte_string ((char *) outbuf, produced_chars,
2178 outp - outbuf);
2179 else
2180 val = make_unibyte_string ((char *) outbuf, produced_chars);
2181 xfree (outbuf);
2182
2183 return val;
2184 }
2185
2186 DEFUN ("register-ccl-program", Fregister_ccl_program, Sregister_ccl_program,
2187 2, 2, 0,
2188 doc: /* Register CCL program CCL-PROG as NAME in `ccl-program-table'.
2189 CCL-PROG should be a compiled CCL program (vector), or nil.
2190 If it is nil, just reserve NAME as a CCL program name.
2191 Return index number of the registered CCL program. */)
2192 (name, ccl_prog)
2193 Lisp_Object name, ccl_prog;
2194 {
2195 int len = ASIZE (Vccl_program_table);
2196 int idx;
2197 Lisp_Object resolved;
2198
2199 CHECK_SYMBOL (name);
2200 resolved = Qnil;
2201 if (!NILP (ccl_prog))
2202 {
2203 CHECK_VECTOR (ccl_prog);
2204 resolved = resolve_symbol_ccl_program (ccl_prog);
2205 if (NILP (resolved))
2206 error ("Error in CCL program");
2207 if (VECTORP (resolved))
2208 {
2209 ccl_prog = resolved;
2210 resolved = Qt;
2211 }
2212 else
2213 resolved = Qnil;
2214 }
2215
2216 for (idx = 0; idx < len; idx++)
2217 {
2218 Lisp_Object slot;
2219
2220 slot = AREF (Vccl_program_table, idx);
2221 if (!VECTORP (slot))
2222 /* This is the first unused slot. Register NAME here. */
2223 break;
2224
2225 if (EQ (name, AREF (slot, 0)))
2226 {
2227 /* Update this slot. */
2228 ASET (slot, 1, ccl_prog);
2229 ASET (slot, 2, resolved);
2230 ASET (slot, 3, Qt);
2231 return make_number (idx);
2232 }
2233 }
2234
2235 if (idx == len)
2236 /* Extend the table. */
2237 Vccl_program_table = larger_vector (Vccl_program_table, len * 2, Qnil);
2238
2239 {
2240 Lisp_Object elt;
2241
2242 elt = Fmake_vector (make_number (4), Qnil);
2243 ASET (elt, 0, name);
2244 ASET (elt, 1, ccl_prog);
2245 ASET (elt, 2, resolved);
2246 ASET (elt, 3, Qt);
2247 ASET (Vccl_program_table, idx, elt);
2248 }
2249
2250 Fput (name, Qccl_program_idx, make_number (idx));
2251 return make_number (idx);
2252 }
2253
2254 /* Register code conversion map.
2255 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
2256 The first element is the start code point.
2257 The other elements are mapped numbers.
2258 Symbol t means to map to an original number before mapping.
2259 Symbol nil means that the corresponding element is empty.
2260 Symbol lambda means to terminate mapping here.
2261 */
2262
2263 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map,
2264 Sregister_code_conversion_map,
2265 2, 2, 0,
2266 doc: /* Register SYMBOL as code conversion map MAP.
2267 Return index number of the registered map. */)
2268 (symbol, map)
2269 Lisp_Object symbol, map;
2270 {
2271 int len = ASIZE (Vcode_conversion_map_vector);
2272 int i;
2273 Lisp_Object index;
2274
2275 CHECK_SYMBOL (symbol);
2276 CHECK_VECTOR (map);
2277
2278 for (i = 0; i < len; i++)
2279 {
2280 Lisp_Object slot = AREF (Vcode_conversion_map_vector, i);
2281
2282 if (!CONSP (slot))
2283 break;
2284
2285 if (EQ (symbol, XCAR (slot)))
2286 {
2287 index = make_number (i);
2288 XSETCDR (slot, map);
2289 Fput (symbol, Qcode_conversion_map, map);
2290 Fput (symbol, Qcode_conversion_map_id, index);
2291 return index;
2292 }
2293 }
2294
2295 if (i == len)
2296 Vcode_conversion_map_vector = larger_vector (Vcode_conversion_map_vector,
2297 len * 2, Qnil);
2298
2299 index = make_number (i);
2300 Fput (symbol, Qcode_conversion_map, map);
2301 Fput (symbol, Qcode_conversion_map_id, index);
2302 ASET (Vcode_conversion_map_vector, i, Fcons (symbol, map));
2303 return index;
2304 }
2305
2306
2307 void
2308 syms_of_ccl (void)
2309 {
2310 staticpro (&Vccl_program_table);
2311 Vccl_program_table = Fmake_vector (make_number (32), Qnil);
2312
2313 Qccl = intern_c_string ("ccl");
2314 staticpro (&Qccl);
2315
2316 Qcclp = intern_c_string ("cclp");
2317 staticpro (&Qcclp);
2318
2319 Qccl_program = intern_c_string ("ccl-program");
2320 staticpro (&Qccl_program);
2321
2322 Qccl_program_idx = intern_c_string ("ccl-program-idx");
2323 staticpro (&Qccl_program_idx);
2324
2325 Qcode_conversion_map = intern_c_string ("code-conversion-map");
2326 staticpro (&Qcode_conversion_map);
2327
2328 Qcode_conversion_map_id = intern_c_string ("code-conversion-map-id");
2329 staticpro (&Qcode_conversion_map_id);
2330
2331 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector,
2332 doc: /* Vector of code conversion maps. */);
2333 Vcode_conversion_map_vector = Fmake_vector (make_number (16), Qnil);
2334
2335 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist,
2336 doc: /* Alist of fontname patterns vs corresponding CCL program.
2337 Each element looks like (REGEXP . CCL-CODE),
2338 where CCL-CODE is a compiled CCL program.
2339 When a font whose name matches REGEXP is used for displaying a character,
2340 CCL-CODE is executed to calculate the code point in the font
2341 from the charset number and position code(s) of the character which are set
2342 in CCL registers R0, R1, and R2 before the execution.
2343 The code point in the font is set in CCL registers R1 and R2
2344 when the execution terminated.
2345 If the font is single-byte font, the register R2 is not used. */);
2346 Vfont_ccl_encoder_alist = Qnil;
2347
2348 DEFVAR_LISP ("translation-hash-table-vector", &Vtranslation_hash_table_vector,
2349 doc: /* Vector containing all translation hash tables ever defined.
2350 Comprises pairs (SYMBOL . TABLE) where SYMBOL and TABLE were set up by calls
2351 to `define-translation-hash-table'. The vector is indexed by the table id
2352 used by CCL. */);
2353 Vtranslation_hash_table_vector = Qnil;
2354
2355 defsubr (&Sccl_program_p);
2356 defsubr (&Sccl_execute);
2357 defsubr (&Sccl_execute_on_string);
2358 defsubr (&Sregister_ccl_program);
2359 defsubr (&Sregister_code_conversion_map);
2360 }
2361
2362 /* arch-tag: bb9a37be-68ce-4576-8d3d-15d750e4a860
2363 (do not change this comment) */
Unnamed repository; edit this file 'description' to name the repository.