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