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
8 National Institute of Advanced Industrial Science and Technology (AIST)
9 Registration Number H13PRO009
11 This file is part of GNU Emacs.
13 GNU Emacs is free software; you can redistribute it and/or modify
14 it under the terms of the GNU General Public License as published by
15 the Free Software Foundation; either version 2, or (at your option)
18 GNU Emacs is distributed in the hope that it will be useful,
19 but WITHOUT ANY WARRANTY; without even the implied warranty of
20 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 GNU General Public License for more details.
23 You should have received a copy of the GNU General Public License
24 along with GNU Emacs; see the file COPYING. If not, write to
25 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26 Boston, MA 02110-1301, USA. */
33 #include "character.h"
38 Lisp_Object Qccl
, Qcclp
;
40 /* This contains all code conversion map available to CCL. */
41 Lisp_Object Vcode_conversion_map_vector
;
43 /* Alist of fontname patterns vs corresponding CCL program. */
44 Lisp_Object Vfont_ccl_encoder_alist
;
46 /* This symbol is a property which assocates with ccl program vector.
47 Ex: (get 'ccl-big5-encoder 'ccl-program) returns ccl program vector. */
48 Lisp_Object Qccl_program
;
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
;
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
;
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
66 Lisp_Object Vccl_program_table
;
68 /* Vector of registered hash tables for translation. */
69 Lisp_Object Vtranslation_hash_table_vector
;
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)])))
75 extern int charset_unicode
;
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
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
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
97 |----------------- integer (28-bit) ------------------|
98 |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
99 |--constant argument--|-register-|-register-|-command-|
100 ccccccccccccccccc RRR rrr XXXXX
102 |------- relative address -------|-register-|-command-|
103 cccccccccccccccccccc rrr XXXXX
105 |------------- constant or other args ----------------|
106 cccccccccccccccccccccccccccc
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
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. */
119 #define CCL_SetRegister 0x00 /* Set register a register value:
120 1:00000000000000000RRRrrrXXXXX
121 ------------------------------
125 #define CCL_SetShortConst 0x01 /* Set register a short constant value:
126 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
127 ------------------------------
128 reg[rrr] = CCCCCCCCCCCCCCCCCCC;
131 #define CCL_SetConst 0x02 /* Set register a constant value:
132 1:00000000000000000000rrrXXXXX
134 ------------------------------
139 #define CCL_SetArray 0x03 /* Set register an element of array:
140 1:CCCCCCCCCCCCCCCCCRRRrrrXXXXX
144 ------------------------------
145 if (0 <= reg[RRR] < CC..C)
146 reg[rrr] = ELEMENT[reg[RRR]];
150 #define CCL_Jump 0x04 /* Jump:
151 1:A--D--D--R--E--S--S-000XXXXX
152 ------------------------------
156 /* Note: If CC..C is greater than 0, the second code is omitted. */
158 #define CCL_JumpCond 0x05 /* Jump conditional:
159 1:A--D--D--R--E--S--S-rrrXXXXX
160 ------------------------------
166 #define CCL_WriteRegisterJump 0x06 /* Write register and jump:
167 1:A--D--D--R--E--S--S-rrrXXXXX
168 ------------------------------
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 -----------------------------
182 /* Note: If read is suspended, the resumed execution starts from the
183 second code (YYYYY == CCL_ReadJump). */
185 #define CCL_WriteConstJump 0x08 /* Write constant and jump:
186 1:A--D--D--R--E--S--S-000XXXXX
188 ------------------------------
193 #define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump:
194 1:A--D--D--R--E--S--S-rrrXXXXX
196 3:A--D--D--R--E--S--S-rrrYYYYY
197 -----------------------------
203 /* Note: If read is suspended, the resumed execution starts from the
204 second code (YYYYY == CCL_ReadJump). */
206 #define CCL_WriteStringJump 0x0A /* Write string and jump:
207 1:A--D--D--R--E--S--S-000XXXXX
209 3:000MSTRIN[0]STRIN[1]STRIN[2]
211 ------------------------------
213 write_multibyte_string (STRING, LENGTH);
215 write_string (STRING, LENGTH);
219 #define CCL_WriteArrayReadJump 0x0B /* Write an array element, read, and jump:
220 1:A--D--D--R--E--S--S-rrrXXXXX
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)
233 /* Note: If read is suspended, the resumed execution starts from the
234 Nth code (YYYYY == CCL_ReadJump). */
236 #define CCL_ReadJump 0x0C /* Read and jump:
237 1:A--D--D--R--E--S--S-rrrYYYYY
238 -----------------------------
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
248 ------------------------------
249 if (0 <= reg[rrr] < CC..C)
250 IC += ADDRESS[reg[rrr]];
252 IC += ADDRESS[CC..C];
255 #define CCL_ReadRegister 0x0E /* Read bytes into registers:
256 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
257 2:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
259 ------------------------------
264 #define CCL_WriteExprConst 0x0F /* write result of expression:
265 1:00000OPERATION000RRR000XXXXX
267 ------------------------------
268 write (reg[RRR] OPERATION CONSTANT);
272 /* Note: If the Nth read is suspended, the resumed execution starts
273 from the Nth code. */
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
281 ------------------------------
283 if (0 <= reg[rrr] < CC..C)
284 IC += ADDRESS[reg[rrr]];
286 IC += ADDRESS[CC..C];
289 #define CCL_WriteRegister 0x11 /* Write registers:
290 1:CCCCCCCCCCCCCCCCCCCrrrXXXXX
291 2:CCCCCCCCCCCCCCCCCCCrrrXXXXX
293 ------------------------------
299 /* Note: If the Nth write is suspended, the resumed execution
300 starts from the Nth code. */
302 #define CCL_WriteExprRegister 0x12 /* Write result of expression
303 1:00000OPERATIONRrrRRR000XXXXX
304 ------------------------------
305 write (reg[RRR] OPERATION reg[Rrr]);
308 #define CCL_Call 0x13 /* Call the CCL program whose ID is
310 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX
311 [2:00000000cccccccccccccccccccc]
312 ------------------------------
320 #define CCL_WriteConstString 0x14 /* Write a constant or a string:
321 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
322 [2:000MSTRIN[0]STRIN[1]STRIN[2]]
324 -----------------------------
329 write_multibyte_string (STRING, CC..C);
331 write_string (STRING, CC..C);
332 IC += (CC..C + 2) / 3;
335 #define CCL_WriteArray 0x15 /* Write an element of array:
336 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
340 ------------------------------
341 if (0 <= reg[rrr] < CC..C)
342 write (ELEMENT[reg[rrr]]);
346 #define CCL_End 0x16 /* Terminate:
347 1:00000000000000000000000XXXXX
348 ------------------------------
352 /* The following two codes execute an assignment arithmetic/logical
353 operation. The form of the operation is like REG OP= OPERAND. */
355 #define CCL_ExprSelfConst 0x17 /* REG OP= constant:
356 1:00000OPERATION000000rrrXXXXX
358 ------------------------------
359 reg[rrr] OPERATION= CONSTANT;
362 #define CCL_ExprSelfReg 0x18 /* REG1 OP= REG2:
363 1:00000OPERATION000RRRrrrXXXXX
364 ------------------------------
365 reg[rrr] OPERATION= reg[RRR];
368 /* The following codes execute an arithmetic/logical operation. The
369 form of the operation is like REG_X = REG_Y OP OPERAND2. */
371 #define CCL_SetExprConst 0x19 /* REG_X = REG_Y OP constant:
372 1:00000OPERATION000RRRrrrXXXXX
374 ------------------------------
375 reg[rrr] = reg[RRR] OPERATION CONSTANT;
379 #define CCL_SetExprReg 0x1A /* REG1 = REG2 OP REG3:
380 1:00000OPERATIONRrrRRRrrrXXXXX
381 ------------------------------
382 reg[rrr] = reg[RRR] OPERATION reg[Rrr];
385 #define CCL_JumpCondExprConst 0x1B /* Jump conditional according to
386 an operation on constant:
387 1:A--D--D--R--E--S--S-rrrXXXXX
390 -----------------------------
391 reg[7] = reg[rrr] OPERATION CONSTANT;
398 #define CCL_JumpCondExprReg 0x1C /* Jump conditional according to
399 an operation on register:
400 1:A--D--D--R--E--S--S-rrrXXXXX
403 -----------------------------
404 reg[7] = reg[rrr] OPERATION reg[RRR];
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
416 -----------------------------
418 reg[7] = reg[rrr] OPERATION CONSTANT;
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
430 -----------------------------
432 reg[7] = reg[rrr] OPERATION reg[RRR];
439 #define CCL_Extension 0x1F /* Extended CCL code
440 1:ExtendedCOMMNDRrrRRRrrrXXXXX
443 ------------------------------
444 extended_command (rrr,RRR,Rrr,ARGS)
448 Here after, Extended CCL Instructions.
449 Bit length of extended command is 14.
450 Therefore, the instruction code range is 0..16384(0x3fff).
453 /* Read a multibyte characeter.
454 A code point is stored into reg[rrr]. A charset ID is stored into
457 #define CCL_ReadMultibyteChar2 0x00 /* Read Multibyte Character
458 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
460 /* Write a multibyte character.
461 Write a character whose code point is reg[rrr] and the charset ID
464 #define CCL_WriteMultibyteChar2 0x01 /* Write Multibyte Character
465 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
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].
470 A translated character is set in reg[rrr] (code point) and reg[RRR]
473 #define CCL_TranslateCharacter 0x02 /* Translate a multibyte character
474 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
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.
479 A translated character is set in reg[rrr] (code point) and reg[RRR]
482 #define CCL_TranslateCharacterConstTbl 0x03 /* Translate a multibyte character
483 1:ExtendedCOMMNDRrrRRRrrrXXXXX
484 2:ARGUMENT(Translation Table ID)
487 /* Iterate looking up MAPs for reg[rrr] starting from the Nth (N =
488 reg[RRR]) MAP until some value is found.
490 Each MAP is a Lisp vector whose element is number, nil, t, or
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.
496 Detail of the map structure is descibed in the comment for
497 CCL_MapMultiple below. */
499 #define CCL_IterateMultipleMap 0x10 /* Iterate multiple maps
500 1:ExtendedCOMMNDXXXRRRrrrXXXXX
507 /* Map the code in reg[rrr] by MAPs starting from the Nth (N =
510 MAPs are supplied in the succeeding CCL codes as follows:
512 When CCL program gives this nested structure of map to this command:
515 (MAP-ID121 MAP-ID122 MAP-ID123)
518 (MAP-ID211 (MAP-ID2111) MAP-ID212)
520 the compiled CCL codes has this sequence:
521 CCL_MapMultiple (CCL code of this command)
522 16 (total number of MAPs and SEPARATORs)
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)
544 (*)....Nest level of MAP-SET must not be over than MAX_MAP_SET_LEVEL.
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.
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:
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.
561 But, when VALm is mapped to VALn and VALn is not a number, the
562 mapping proceed as below:
564 If VALn is nil, the lastest map is ignored and the mapping of VALm
565 proceed to the next map.
567 In VALn is t, VALm is reverted to reg[rrr] and the mapping of VALm
568 proceed to the next map.
570 If VALn is lambda, move to the next map set like reaching to the
571 end of the current map set.
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.
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],
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.
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 */
590 #define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
591 1:ExtendedCOMMNDXXXRRRrrrXXXXX
603 #define MAX_MAP_SET_LEVEL 30
611 static tr_stack mapping_stack
[MAX_MAP_SET_LEVEL
];
612 static tr_stack
*mapping_stack_pointer
;
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
;
618 #define PUSH_MAPPING_STACK(restlen, orig) \
621 mapping_stack_pointer->rest_length = (restlen); \
622 mapping_stack_pointer->orig_val = (orig); \
623 mapping_stack_pointer++; \
627 #define POP_MAPPING_STACK(restlen, orig) \
630 mapping_stack_pointer--; \
631 (restlen) = mapping_stack_pointer->rest_length; \
632 (orig) = mapping_stack_pointer->orig_val; \
636 #define CCL_CALL_FOR_MAP_INSTRUCTION(symbol, ret_ic) \
639 struct ccl_program called_ccl; \
640 if (stack_idx >= 256 \
641 || (setup_ccl_program (&called_ccl, (symbol)) != 0)) \
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; \
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; \
655 ccl_prog = called_ccl.prog; \
656 ic = CCL_HEADER_MAIN; \
657 eof_ic = XFASTINT (ccl_prog[CCL_HEADER_EOF]); \
662 #define CCL_MapSingle 0x12 /* Map by single code conversion map
663 1:ExtendedCOMMNDXXXRRRrrrXXXXX
665 ------------------------------
666 Map reg[rrr] by MAP-ID.
667 If some valid mapping is found,
668 set reg[rrr] to the result,
673 #define CCL_LookupIntConstTbl 0x13 /* Lookup multibyte character by
674 integer key. Afterwards R7 set
675 to 1 iff lookup succeeded.
676 1:ExtendedCOMMNDRrrRRRXXXXXXXX
677 2:ARGUMENT(Hash table ID) */
679 #define CCL_LookupCharConstTbl 0x14 /* Lookup integer by multibyte
680 character key. Afterwards R7 set
681 to 1 iff lookup succeeded.
682 1:ExtendedCOMMNDRrrRRRrrrXXXXX
683 2:ARGUMENT(Hash table ID) */
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) */
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) */
711 /* Terminate CCL program successfully. */
712 #define CCL_SUCCESS \
715 ccl->status = CCL_STAT_SUCCESS; \
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) \
727 ccl->status = stat; \
732 /* Terminate CCL program because of invalid command. Should not occur
733 in the normal case. */
736 #define CCL_INVALID_CMD \
739 ccl->status = CCL_STAT_INVALID_CMD; \
740 goto ccl_error_handler; \
746 #define CCL_INVALID_CMD \
749 ccl_debug_hook (this_ic); \
750 ccl->status = CCL_STAT_INVALID_CMD; \
751 goto ccl_error_handler; \
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) \
763 else if (dst < dst_end) \
766 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
769 /* Write a string at ccl_prog[IC] of length LEN to the current output
771 #define CCL_WRITE_STRING(len) \
776 else if (dst + len <= dst_end) \
778 if (XFASTINT (ccl_prog[ic]) & 0x1000000) \
779 for (i = 0; i < len; i++) \
780 *dst++ = XFASTINT (ccl_prog[ic + i]) & 0xFFFFFF; \
782 for (i = 0; i < len; i++) \
783 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
784 >> ((2 - (i % 3)) * 8)) & 0xFF; \
787 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
790 /* Read one byte from the current input buffer into Rth register. */
791 #define CCL_READ_CHAR(r) \
795 else if (src < src_end) \
797 else if (ccl->last_block) \
804 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
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'. */
811 #define CCL_DECODE_CHAR(id, code) \
812 ((id) == 0 ? (code) \
813 : (charset = CHARSET_FROM_ID ((id)), DECODE_CHAR (charset, (code))))
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'. */
819 #define CCL_ENCODE_CHAR(c, charset_list, id, encoded) \
823 charset = char_charset ((c), (charset_list), &code); \
824 if (! charset && ! NILP (charset_list)) \
825 charset = char_charset ((c), Qnil, &code); \
828 (id) = CHARSET_ID (charset); \
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
842 #define CCL_DEBUG_BACKTRACE_LEN 256
843 int ccl_backtrace_table
[CCL_DEBUG_BACKTRACE_LEN
];
844 int ccl_backtrace_idx
;
847 ccl_debug_hook (int ic
)
854 struct ccl_prog_stack
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. */
861 /* For the moment, we only support depth 256 of stack. */
862 static struct ccl_prog_stack ccl_prog_stack_struct
[256];
865 ccl_driver (ccl
, source
, destination
, src_size
, dst_size
, charset_list
)
866 struct ccl_program
*ccl
;
867 int *source
, *destination
;
868 int src_size
, dst_size
;
869 Lisp_Object charset_list
;
871 register int *reg
= ccl
->reg
;
872 register int ic
= ccl
->ic
;
873 register int code
= 0, field1
, field2
;
874 register Lisp_Object
*ccl_prog
= ccl
->prog
;
875 int *src
= source
, *src_end
= src
+ src_size
;
876 int *dst
= destination
, *dst_end
= dst
+ dst_size
;
879 int stack_idx
= ccl
->stack_idx
;
880 /* Instruction counter of the current CCL code. */
882 struct charset
*charset
;
883 int eof_ic
= ccl
->eof_ic
;
887 ic
= CCL_HEADER_MAIN
;
889 if (ccl
->buf_magnification
== 0) /* We can't read/produce any bytes. */
892 /* Set mapping stack pointer. */
893 mapping_stack_pointer
= mapping_stack
;
896 ccl_backtrace_idx
= 0;
903 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
904 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
905 ccl_backtrace_idx
= 0;
906 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
909 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
911 /* We can't just signal Qquit, instead break the loop as if
912 the whole data is processed. Don't reset Vquit_flag, it
913 must be handled later at a safer place. */
915 src
= source
+ src_size
;
916 ccl
->status
= CCL_STAT_QUIT
;
921 code
= XINT (ccl_prog
[ic
]); ic
++;
923 field2
= (code
& 0xFF) >> 5;
926 #define RRR (field1 & 7)
927 #define Rrr ((field1 >> 3) & 7)
929 #define EXCMD (field1 >> 6)
933 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
937 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
941 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
942 reg
[rrr
] = XINT (ccl_prog
[ic
]);
946 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
949 if ((unsigned int) i
< j
)
950 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
954 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
958 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
963 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
969 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
973 CCL_READ_CHAR (reg
[rrr
]);
977 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
978 i
= XINT (ccl_prog
[ic
]);
983 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
984 i
= XINT (ccl_prog
[ic
]);
987 CCL_READ_CHAR (reg
[rrr
]);
991 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
992 j
= XINT (ccl_prog
[ic
]);
994 CCL_WRITE_STRING (j
);
998 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
1000 j
= XINT (ccl_prog
[ic
]);
1001 if ((unsigned int) i
< j
)
1003 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
1007 CCL_READ_CHAR (reg
[rrr
]);
1008 ic
+= ADDR
- (j
+ 2);
1011 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
1012 CCL_READ_CHAR (reg
[rrr
]);
1016 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1017 CCL_READ_CHAR (reg
[rrr
]);
1018 /* fall through ... */
1019 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1020 if ((unsigned int) reg
[rrr
] < field1
)
1021 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
1023 ic
+= XINT (ccl_prog
[ic
+ field1
]);
1026 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
1029 CCL_READ_CHAR (reg
[rrr
]);
1031 code
= XINT (ccl_prog
[ic
]); ic
++;
1033 field2
= (code
& 0xFF) >> 5;
1037 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
1040 j
= XINT (ccl_prog
[ic
]);
1042 jump_address
= ic
+ 1;
1045 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
1051 code
= XINT (ccl_prog
[ic
]); ic
++;
1053 field2
= (code
& 0xFF) >> 5;
1057 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
1065 case CCL_Call
: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
1070 /* If FFF is nonzero, the CCL program ID is in the
1074 prog_id
= XINT (ccl_prog
[ic
]);
1080 if (stack_idx
>= 256
1082 || prog_id
>= ASIZE (Vccl_program_table
)
1083 || (slot
= AREF (Vccl_program_table
, prog_id
), !VECTORP (slot
))
1084 || !VECTORP (AREF (slot
, 1)))
1088 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
1089 ic
= ccl_prog_stack_struct
[0].ic
;
1090 eof_ic
= ccl_prog_stack_struct
[0].eof_ic
;
1095 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
1096 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
1097 ccl_prog_stack_struct
[stack_idx
].eof_ic
= eof_ic
;
1099 ccl_prog
= XVECTOR (AREF (slot
, 1))->contents
;
1100 ic
= CCL_HEADER_MAIN
;
1101 eof_ic
= XFASTINT (ccl_prog
[CCL_HEADER_EOF
]);
1105 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1107 CCL_WRITE_CHAR (field1
);
1110 CCL_WRITE_STRING (field1
);
1111 ic
+= (field1
+ 2) / 3;
1115 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1117 if ((unsigned int) i
< field1
)
1119 j
= XINT (ccl_prog
[ic
+ i
]);
1125 case CCL_End
: /* 0000000000000000000000XXXXX */
1129 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
1130 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
1131 eof_ic
= ccl_prog_stack_struct
[stack_idx
].eof_ic
;
1138 /* ccl->ic should points to this command code again to
1139 suppress further processing. */
1143 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
1144 i
= XINT (ccl_prog
[ic
]);
1149 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
1156 case CCL_PLUS
: reg
[rrr
] += i
; break;
1157 case CCL_MINUS
: reg
[rrr
] -= i
; break;
1158 case CCL_MUL
: reg
[rrr
] *= i
; break;
1159 case CCL_DIV
: reg
[rrr
] /= i
; break;
1160 case CCL_MOD
: reg
[rrr
] %= i
; break;
1161 case CCL_AND
: reg
[rrr
] &= i
; break;
1162 case CCL_OR
: reg
[rrr
] |= i
; break;
1163 case CCL_XOR
: reg
[rrr
] ^= i
; break;
1164 case CCL_LSH
: reg
[rrr
] <<= i
; break;
1165 case CCL_RSH
: reg
[rrr
] >>= i
; break;
1166 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
1167 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
1168 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
1169 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
1170 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
1171 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
1172 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
1173 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
1174 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
1175 default: CCL_INVALID_CMD
;
1179 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1181 j
= XINT (ccl_prog
[ic
]);
1183 jump_address
= ++ic
;
1186 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1193 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1194 CCL_READ_CHAR (reg
[rrr
]);
1195 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1197 op
= XINT (ccl_prog
[ic
]);
1198 jump_address
= ic
++ + ADDR
;
1199 j
= XINT (ccl_prog
[ic
]);
1204 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1205 CCL_READ_CHAR (reg
[rrr
]);
1206 case CCL_JumpCondExprReg
:
1208 op
= XINT (ccl_prog
[ic
]);
1209 jump_address
= ic
++ + ADDR
;
1210 j
= reg
[XINT (ccl_prog
[ic
])];
1217 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1218 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1219 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1220 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1221 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1222 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1223 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1224 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1225 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1226 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1227 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1228 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1229 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1230 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1231 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1232 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1233 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1234 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1235 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1236 case CCL_DECODE_SJIS
:
1244 case CCL_ENCODE_SJIS
:
1252 default: CCL_INVALID_CMD
;
1255 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1268 case CCL_ReadMultibyteChar2
:
1272 CCL_ENCODE_CHAR (i
, charset_list
, reg
[RRR
], reg
[rrr
]);
1275 case CCL_WriteMultibyteChar2
:
1278 i
= CCL_DECODE_CHAR (reg
[RRR
], reg
[rrr
]);
1282 case CCL_TranslateCharacter
:
1283 i
= CCL_DECODE_CHAR (reg
[RRR
], reg
[rrr
]);
1284 op
= translate_char (GET_TRANSLATION_TABLE (reg
[Rrr
]), i
);
1285 CCL_ENCODE_CHAR (op
, charset_list
, reg
[RRR
], reg
[rrr
]);
1288 case CCL_TranslateCharacterConstTbl
:
1289 op
= XINT (ccl_prog
[ic
]); /* table */
1291 i
= CCL_DECODE_CHAR (reg
[RRR
], reg
[rrr
]);
1292 op
= translate_char (GET_TRANSLATION_TABLE (op
), i
);
1293 CCL_ENCODE_CHAR (op
, charset_list
, reg
[RRR
], reg
[rrr
]);
1296 case CCL_LookupIntConstTbl
:
1297 op
= XINT (ccl_prog
[ic
]); /* table */
1300 struct Lisp_Hash_Table
*h
= GET_HASH_TABLE (op
);
1302 op
= hash_lookup (h
, make_number (reg
[RRR
]), NULL
);
1306 opl
= HASH_VALUE (h
, op
);
1307 if (! CHARACTERP (opl
))
1309 reg
[RRR
] = charset_unicode
;
1311 reg
[7] = 1; /* r7 true for success */
1318 case CCL_LookupCharConstTbl
:
1319 op
= XINT (ccl_prog
[ic
]); /* table */
1321 i
= CCL_DECODE_CHAR (reg
[RRR
], reg
[rrr
]);
1323 struct Lisp_Hash_Table
*h
= GET_HASH_TABLE (op
);
1325 op
= hash_lookup (h
, make_number (i
), NULL
);
1329 opl
= HASH_VALUE (h
, op
);
1330 if (!INTEGERP (opl
))
1332 reg
[RRR
] = XINT (opl
);
1333 reg
[7] = 1; /* r7 true for success */
1340 case CCL_IterateMultipleMap
:
1342 Lisp_Object map
, content
, attrib
, value
;
1343 int point
, size
, fin_ic
;
1345 j
= XINT (ccl_prog
[ic
++]); /* number of maps. */
1348 if ((j
> reg
[RRR
]) && (j
>= 0))
1363 size
= ASIZE (Vcode_conversion_map_vector
);
1364 point
= XINT (ccl_prog
[ic
++]);
1365 if (point
>= size
) continue;
1366 map
= AREF (Vcode_conversion_map_vector
, point
);
1368 /* Check map varidity. */
1369 if (!CONSP (map
)) continue;
1371 if (!VECTORP (map
)) continue;
1373 if (size
<= 1) continue;
1375 content
= AREF (map
, 0);
1378 [STARTPOINT VAL1 VAL2 ...] or
1379 [t ELELMENT STARTPOINT ENDPOINT] */
1380 if (NUMBERP (content
))
1382 point
= XUINT (content
);
1383 point
= op
- point
+ 1;
1384 if (!((point
>= 1) && (point
< size
))) continue;
1385 content
= AREF (map
, point
);
1387 else if (EQ (content
, Qt
))
1389 if (size
!= 4) continue;
1390 if ((op
>= XUINT (AREF (map
, 2)))
1391 && (op
< XUINT (AREF (map
, 3))))
1392 content
= AREF (map
, 1);
1401 else if (NUMBERP (content
))
1404 reg
[rrr
] = XINT(content
);
1407 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1412 else if (CONSP (content
))
1414 attrib
= XCAR (content
);
1415 value
= XCDR (content
);
1416 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1419 reg
[rrr
] = XUINT (value
);
1422 else if (SYMBOLP (content
))
1423 CCL_CALL_FOR_MAP_INSTRUCTION (content
, fin_ic
);
1433 case CCL_MapMultiple
:
1435 Lisp_Object map
, content
, attrib
, value
;
1436 int point
, size
, map_vector_size
;
1437 int map_set_rest_length
, fin_ic
;
1438 int current_ic
= this_ic
;
1440 /* inhibit recursive call on MapMultiple. */
1441 if (stack_idx_of_map_multiple
> 0)
1443 if (stack_idx_of_map_multiple
<= stack_idx
)
1445 stack_idx_of_map_multiple
= 0;
1446 mapping_stack_pointer
= mapping_stack
;
1451 mapping_stack_pointer
= mapping_stack
;
1452 stack_idx_of_map_multiple
= 0;
1454 map_set_rest_length
=
1455 XINT (ccl_prog
[ic
++]); /* number of maps and separators. */
1456 fin_ic
= ic
+ map_set_rest_length
;
1459 if ((map_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1463 map_set_rest_length
-= i
;
1469 mapping_stack_pointer
= mapping_stack
;
1473 if (mapping_stack_pointer
<= (mapping_stack
+ 1))
1475 /* Set up initial state. */
1476 mapping_stack_pointer
= mapping_stack
;
1477 PUSH_MAPPING_STACK (0, op
);
1482 /* Recover after calling other ccl program. */
1485 POP_MAPPING_STACK (map_set_rest_length
, orig_op
);
1486 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1490 /* Regard it as Qnil. */
1494 map_set_rest_length
--;
1497 /* Regard it as Qt. */
1501 map_set_rest_length
--;
1504 /* Regard it as Qlambda. */
1506 i
+= map_set_rest_length
;
1507 ic
+= map_set_rest_length
;
1508 map_set_rest_length
= 0;
1511 /* Regard it as normal mapping. */
1512 i
+= map_set_rest_length
;
1513 ic
+= map_set_rest_length
;
1514 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1518 map_vector_size
= ASIZE (Vcode_conversion_map_vector
);
1521 for (;map_set_rest_length
> 0;i
++, ic
++, map_set_rest_length
--)
1523 point
= XINT(ccl_prog
[ic
]);
1526 /* +1 is for including separator. */
1528 if (mapping_stack_pointer
1529 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1531 PUSH_MAPPING_STACK (map_set_rest_length
- point
,
1533 map_set_rest_length
= point
;
1538 if (point
>= map_vector_size
) continue;
1539 map
= AREF (Vcode_conversion_map_vector
, point
);
1541 /* Check map varidity. */
1542 if (!CONSP (map
)) continue;
1544 if (!VECTORP (map
)) continue;
1546 if (size
<= 1) continue;
1548 content
= AREF (map
, 0);
1551 [STARTPOINT VAL1 VAL2 ...] or
1552 [t ELEMENT STARTPOINT ENDPOINT] */
1553 if (NUMBERP (content
))
1555 point
= XUINT (content
);
1556 point
= op
- point
+ 1;
1557 if (!((point
>= 1) && (point
< size
))) continue;
1558 content
= AREF (map
, point
);
1560 else if (EQ (content
, Qt
))
1562 if (size
!= 4) continue;
1563 if ((op
>= XUINT (AREF (map
, 2))) &&
1564 (op
< XUINT (AREF (map
, 3))))
1565 content
= AREF (map
, 1);
1576 if (NUMBERP (content
))
1578 op
= XINT (content
);
1579 i
+= map_set_rest_length
- 1;
1580 ic
+= map_set_rest_length
- 1;
1581 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1582 map_set_rest_length
++;
1584 else if (CONSP (content
))
1586 attrib
= XCAR (content
);
1587 value
= XCDR (content
);
1588 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1591 i
+= map_set_rest_length
- 1;
1592 ic
+= map_set_rest_length
- 1;
1593 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1594 map_set_rest_length
++;
1596 else if (EQ (content
, Qt
))
1600 else if (EQ (content
, Qlambda
))
1602 i
+= map_set_rest_length
;
1603 ic
+= map_set_rest_length
;
1606 else if (SYMBOLP (content
))
1608 if (mapping_stack_pointer
1609 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1611 PUSH_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1612 PUSH_MAPPING_STACK (map_set_rest_length
, op
);
1613 stack_idx_of_map_multiple
= stack_idx
+ 1;
1614 CCL_CALL_FOR_MAP_INSTRUCTION (content
, current_ic
);
1619 if (mapping_stack_pointer
<= (mapping_stack
+ 1))
1621 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1622 i
+= map_set_rest_length
;
1623 ic
+= map_set_rest_length
;
1624 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1634 Lisp_Object map
, attrib
, value
, content
;
1636 j
= XINT (ccl_prog
[ic
++]); /* map_id */
1638 if (j
>= ASIZE (Vcode_conversion_map_vector
))
1643 map
= AREF (Vcode_conversion_map_vector
, j
);
1656 point
= XUINT (AREF (map
, 0));
1657 point
= op
- point
+ 1;
1660 (!((point
>= 1) && (point
< size
))))
1665 content
= AREF (map
, point
);
1668 else if (NUMBERP (content
))
1669 reg
[rrr
] = XINT (content
);
1670 else if (EQ (content
, Qt
));
1671 else if (CONSP (content
))
1673 attrib
= XCAR (content
);
1674 value
= XCDR (content
);
1675 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1677 reg
[rrr
] = XUINT(value
);
1680 else if (SYMBOLP (content
))
1681 CCL_CALL_FOR_MAP_INSTRUCTION (content
, ic
);
1699 /* The suppress_error member is set when e.g. a CCL-based coding
1700 system is used for terminal output. */
1701 if (!ccl
->suppress_error
&& destination
)
1703 /* We can insert an error message only if DESTINATION is
1704 specified and we still have a room to store the message
1712 switch (ccl
->status
)
1714 case CCL_STAT_INVALID_CMD
:
1715 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1716 code
& 0x1F, code
, this_ic
);
1719 int i
= ccl_backtrace_idx
- 1;
1722 msglen
= strlen (msg
);
1723 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1725 bcopy (msg
, dst
, msglen
);
1729 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1731 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1732 if (ccl_backtrace_table
[i
] == 0)
1734 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1735 msglen
= strlen (msg
);
1736 if (dst
+ msglen
> (dst_bytes
? dst_end
: src
))
1738 bcopy (msg
, dst
, msglen
);
1747 sprintf(msg
, "\nCCL: Quited.");
1751 sprintf(msg
, "\nCCL: Unknown error type (%d)", ccl
->status
);
1754 msglen
= strlen (msg
);
1755 if (dst
+ msglen
<= dst_end
)
1757 for (i
= 0; i
< msglen
; i
++)
1761 if (ccl
->status
== CCL_STAT_INVALID_CMD
)
1763 #if 0 /* If the remaining bytes contain 0x80..0x9F, copying them
1764 results in an invalid multibyte sequence. */
1766 /* Copy the remaining source data. */
1767 int i
= src_end
- src
;
1768 if (dst_bytes
&& (dst_end
- dst
) < i
)
1770 bcopy (src
, dst
, i
);
1774 /* Signal that we've consumed everything. */
1782 ccl
->stack_idx
= stack_idx
;
1783 ccl
->prog
= ccl_prog
;
1784 ccl
->consumed
= src
- source
;
1786 ccl
->produced
= dst
- destination
;
1791 /* Resolve symbols in the specified CCL code (Lisp vector). This
1792 function converts symbols of code conversion maps and character
1793 translation tables embeded in the CCL code into their ID numbers.
1795 The return value is a vector (CCL itself or a new vector in which
1796 all symbols are resolved), Qt if resolving of some symbol failed,
1797 or nil if CCL contains invalid data. */
1800 resolve_symbol_ccl_program (ccl
)
1803 int i
, veclen
, unresolved
= 0;
1804 Lisp_Object result
, contents
, val
;
1807 veclen
= ASIZE (result
);
1809 for (i
= 0; i
< veclen
; i
++)
1811 contents
= AREF (result
, i
);
1812 if (INTEGERP (contents
))
1814 else if (CONSP (contents
)
1815 && SYMBOLP (XCAR (contents
))
1816 && SYMBOLP (XCDR (contents
)))
1818 /* This is the new style for embedding symbols. The form is
1819 (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
1822 if (EQ (result
, ccl
))
1823 result
= Fcopy_sequence (ccl
);
1825 val
= Fget (XCAR (contents
), XCDR (contents
));
1827 AREF (result
, i
) = val
;
1832 else if (SYMBOLP (contents
))
1834 /* This is the old style for embedding symbols. This style
1835 may lead to a bug if, for instance, a translation table
1836 and a code conversion map have the same name. */
1837 if (EQ (result
, ccl
))
1838 result
= Fcopy_sequence (ccl
);
1840 val
= Fget (contents
, Qtranslation_table_id
);
1842 AREF (result
, i
) = val
;
1845 val
= Fget (contents
, Qcode_conversion_map_id
);
1847 AREF (result
, i
) = val
;
1850 val
= Fget (contents
, Qccl_program_idx
);
1852 AREF (result
, i
) = val
;
1862 return (unresolved
? Qt
: result
);
1865 /* Return the compiled code (vector) of CCL program CCL_PROG.
1866 CCL_PROG is a name (symbol) of the program or already compiled
1867 code. If necessary, resolve symbols in the compiled code to index
1868 numbers. If we failed to get the compiled code or to resolve
1869 symbols, return Qnil. */
1872 ccl_get_compiled_code (ccl_prog
, idx
)
1873 Lisp_Object ccl_prog
;
1876 Lisp_Object val
, slot
;
1878 if (VECTORP (ccl_prog
))
1880 val
= resolve_symbol_ccl_program (ccl_prog
);
1882 return (VECTORP (val
) ? val
: Qnil
);
1884 if (!SYMBOLP (ccl_prog
))
1887 val
= Fget (ccl_prog
, Qccl_program_idx
);
1889 || XINT (val
) >= ASIZE (Vccl_program_table
))
1891 slot
= AREF (Vccl_program_table
, XINT (val
));
1892 if (! VECTORP (slot
)
1893 || ASIZE (slot
) != 4
1894 || ! VECTORP (AREF (slot
, 1)))
1897 if (NILP (AREF (slot
, 2)))
1899 val
= resolve_symbol_ccl_program (AREF (slot
, 1));
1900 if (! VECTORP (val
))
1902 AREF (slot
, 1) = val
;
1903 AREF (slot
, 2) = Qt
;
1905 return AREF (slot
, 1);
1908 /* Setup fields of the structure pointed by CCL appropriately for the
1909 execution of CCL program CCL_PROG. CCL_PROG is the name (symbol)
1910 of the CCL program or the already compiled code (vector).
1911 Return 0 if we succeed this setup, else return -1.
1913 If CCL_PROG is nil, we just reset the structure pointed by CCL. */
1915 setup_ccl_program (ccl
, ccl_prog
)
1916 struct ccl_program
*ccl
;
1917 Lisp_Object ccl_prog
;
1921 if (! NILP (ccl_prog
))
1923 struct Lisp_Vector
*vp
;
1925 ccl_prog
= ccl_get_compiled_code (ccl_prog
, &ccl
->idx
);
1926 if (! VECTORP (ccl_prog
))
1928 vp
= XVECTOR (ccl_prog
);
1929 ccl
->size
= vp
->size
;
1930 ccl
->prog
= vp
->contents
;
1931 ccl
->eof_ic
= XINT (vp
->contents
[CCL_HEADER_EOF
]);
1932 ccl
->buf_magnification
= XINT (vp
->contents
[CCL_HEADER_BUF_MAG
]);
1937 slot
= AREF (Vccl_program_table
, ccl
->idx
);
1938 ASET (slot
, 3, Qnil
);
1941 ccl
->ic
= CCL_HEADER_MAIN
;
1942 for (i
= 0; i
< 8; i
++)
1944 ccl
->last_block
= 0;
1945 ccl
->private_state
= 0;
1948 ccl
->suppress_error
= 0;
1949 ccl
->eight_bit_control
= 0;
1954 /* Check if CCL is updated or not. If not, re-setup members of CCL. */
1957 check_ccl_update (ccl
)
1958 struct ccl_program
*ccl
;
1960 Lisp_Object slot
, ccl_prog
;
1964 slot
= AREF (Vccl_program_table
, ccl
->idx
);
1965 if (NILP (AREF (slot
, 3)))
1967 ccl_prog
= ccl_get_compiled_code (AREF (slot
, 0), &ccl
->idx
);
1968 if (! VECTORP (ccl_prog
))
1970 ccl
->size
= ASIZE (ccl_prog
);
1971 ccl
->prog
= XVECTOR (ccl_prog
)->contents
;
1972 ccl
->eof_ic
= XINT (AREF (ccl_prog
, CCL_HEADER_EOF
));
1973 ccl
->buf_magnification
= XINT (AREF (ccl_prog
, CCL_HEADER_BUF_MAG
));
1974 ASET (slot
, 3, Qnil
);
1979 DEFUN ("ccl-program-p", Fccl_program_p
, Sccl_program_p
, 1, 1, 0,
1980 doc
: /* Return t if OBJECT is a CCL program name or a compiled CCL program code.
1981 See the documentation of `define-ccl-program' for the detail of CCL program. */)
1987 if (VECTORP (object
))
1989 val
= resolve_symbol_ccl_program (object
);
1990 return (VECTORP (val
) ? Qt
: Qnil
);
1992 if (!SYMBOLP (object
))
1995 val
= Fget (object
, Qccl_program_idx
);
1996 return ((! NATNUMP (val
)
1997 || XINT (val
) >= ASIZE (Vccl_program_table
))
2001 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
2002 doc
: /* Execute CCL-PROGRAM with registers initialized by REGISTERS.
2004 CCL-PROGRAM is a CCL program name (symbol)
2005 or compiled code generated by `ccl-compile' (for backward compatibility.
2006 In the latter case, the execution overhead is bigger than in the former).
2007 No I/O commands should appear in CCL-PROGRAM.
2009 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value
2010 for the Nth register.
2012 As side effect, each element of REGISTERS holds the value of
2013 the corresponding register after the execution.
2015 See the documentation of `define-ccl-program' for a definition of CCL
2018 Lisp_Object ccl_prog
, reg
;
2020 struct ccl_program ccl
;
2023 if (setup_ccl_program (&ccl
, ccl_prog
) < 0)
2024 error ("Invalid CCL program");
2027 if (ASIZE (reg
) != 8)
2028 error ("Length of vector REGISTERS is not 8");
2030 for (i
= 0; i
< 8; i
++)
2031 ccl
.reg
[i
] = (INTEGERP (AREF (reg
, i
))
2032 ? XINT (AREF (reg
, i
))
2035 ccl_driver (&ccl
, NULL
, NULL
, 0, 0, Qnil
);
2037 if (ccl
.status
!= CCL_STAT_SUCCESS
)
2038 error ("Error in CCL program at %dth code", ccl
.ic
);
2040 for (i
= 0; i
< 8; i
++)
2041 XSETINT (AREF (reg
, i
), ccl
.reg
[i
]);
2045 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
2047 doc
: /* Execute CCL-PROGRAM with initial STATUS on STRING.
2049 CCL-PROGRAM is a symbol registered by `register-ccl-program',
2050 or a compiled code generated by `ccl-compile' (for backward compatibility,
2051 in this case, the execution is slower).
2053 Read buffer is set to STRING, and write buffer is allocated automatically.
2055 STATUS is a vector of [R0 R1 ... R7 IC], where
2056 R0..R7 are initial values of corresponding registers,
2057 IC is the instruction counter specifying from where to start the program.
2058 If R0..R7 are nil, they are initialized to 0.
2059 If IC is nil, it is initialized to head of the CCL program.
2061 If optional 4th arg CONTINUE is non-nil, keep IC on read operation
2062 when read buffer is exausted, else, IC is always set to the end of
2063 CCL-PROGRAM on exit.
2065 It returns the contents of write buffer as a string,
2066 and as side effect, STATUS is updated.
2067 If the optional 5th arg UNIBYTE-P is non-nil, the returned string
2068 is a unibyte string. By default it is a multibyte string.
2070 See the documentation of `define-ccl-program' for the detail of CCL program.
2071 usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBYTE-P) */)
2072 (ccl_prog
, status
, str
, contin
, unibyte_p
)
2073 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
2076 struct ccl_program ccl
;
2079 unsigned char *outbuf
, *outp
;
2080 int str_chars
, str_bytes
;
2081 #define CCL_EXECUTE_BUF_SIZE 1024
2082 int source
[CCL_EXECUTE_BUF_SIZE
], destination
[CCL_EXECUTE_BUF_SIZE
];
2083 int consumed_chars
, consumed_bytes
, produced_chars
;
2085 if (setup_ccl_program (&ccl
, ccl_prog
) < 0)
2086 error ("Invalid CCL program");
2088 CHECK_VECTOR (status
);
2089 if (ASIZE (status
) != 9)
2090 error ("Length of vector STATUS is not 9");
2093 str_chars
= SCHARS (str
);
2094 str_bytes
= SBYTES (str
);
2096 for (i
= 0; i
< 8; i
++)
2098 if (NILP (AREF (status
, i
)))
2099 XSETINT (AREF (status
, i
), 0);
2100 if (INTEGERP (AREF (status
, i
)))
2101 ccl
.reg
[i
] = XINT (AREF (status
, i
));
2103 if (INTEGERP (AREF (status
, i
)))
2105 i
= XFASTINT (AREF (status
, 8));
2106 if (ccl
.ic
< i
&& i
< ccl
.size
)
2110 outbufsize
= (ccl
.buf_magnification
2111 ? str_bytes
* ccl
.buf_magnification
+ 256
2113 outp
= outbuf
= (unsigned char *) xmalloc (outbufsize
);
2115 consumed_chars
= consumed_bytes
= 0;
2119 const unsigned char *p
= SDATA (str
) + consumed_bytes
;
2120 const unsigned char *endp
= SDATA (str
) + str_bytes
;
2124 if (endp
- p
== str_chars
- consumed_chars
)
2125 while (i
< CCL_EXECUTE_BUF_SIZE
&& p
< endp
)
2128 while (i
< CCL_EXECUTE_BUF_SIZE
&& p
< endp
)
2129 source
[i
++] = STRING_CHAR_ADVANCE (p
);
2130 consumed_chars
+= i
;
2131 consumed_bytes
= p
- SDATA (str
);
2133 if (consumed_bytes
== str_bytes
)
2134 ccl
.last_block
= NILP (contin
);
2139 ccl_driver (&ccl
, src
, destination
, src_size
, CCL_EXECUTE_BUF_SIZE
,
2141 produced_chars
+= ccl
.produced
;
2142 if (NILP (unibyte_p
))
2144 if (outp
- outbuf
+ MAX_MULTIBYTE_LENGTH
* ccl
.produced
2147 int offset
= outp
- outbuf
;
2148 outbufsize
+= MAX_MULTIBYTE_LENGTH
* ccl
.produced
;
2149 outbuf
= (unsigned char *) xrealloc (outbuf
, outbufsize
);
2150 outp
= outbuf
+ offset
;
2152 for (i
= 0; i
< ccl
.produced
; i
++)
2153 CHAR_STRING_ADVANCE (destination
[i
], outp
);
2157 if (outp
- outbuf
+ ccl
.produced
> outbufsize
)
2159 int offset
= outp
- outbuf
;
2160 outbufsize
+= ccl
.produced
;
2161 outbuf
= (unsigned char *) xrealloc (outbuf
, outbufsize
);
2162 outp
= outbuf
+ offset
;
2164 for (i
= 0; i
< ccl
.produced
; i
++)
2165 *outp
++ = destination
[i
];
2167 src
+= ccl
.consumed
;
2168 src_size
-= ccl
.consumed
;
2169 if (ccl
.status
!= CCL_STAT_SUSPEND_BY_DST
)
2173 if (ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
2174 || str_chars
== consumed_chars
)
2178 if (ccl
.status
== CCL_STAT_INVALID_CMD
)
2179 error ("Error in CCL program at %dth code", ccl
.ic
);
2180 if (ccl
.status
== CCL_STAT_QUIT
)
2181 error ("CCL program interrupted at %dth code", ccl
.ic
);
2183 for (i
= 0; i
< 8; i
++)
2184 ASET (status
, i
, make_number (ccl
.reg
[i
]));
2185 ASET (status
, 8, make_number (ccl
.ic
));
2187 if (NILP (unibyte_p
))
2188 val
= make_multibyte_string ((char *) outbuf
, produced_chars
,
2191 val
= make_unibyte_string ((char *) outbuf
, produced_chars
);
2197 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
2199 doc
: /* Register CCL program CCL-PROG as NAME in `ccl-program-table'.
2200 CCL-PROG should be a compiled CCL program (vector), or nil.
2201 If it is nil, just reserve NAME as a CCL program name.
2202 Return index number of the registered CCL program. */)
2204 Lisp_Object name
, ccl_prog
;
2206 int len
= ASIZE (Vccl_program_table
);
2208 Lisp_Object resolved
;
2210 CHECK_SYMBOL (name
);
2212 if (!NILP (ccl_prog
))
2214 CHECK_VECTOR (ccl_prog
);
2215 resolved
= resolve_symbol_ccl_program (ccl_prog
);
2216 if (NILP (resolved
))
2217 error ("Error in CCL program");
2218 if (VECTORP (resolved
))
2220 ccl_prog
= resolved
;
2227 for (idx
= 0; idx
< len
; idx
++)
2231 slot
= AREF (Vccl_program_table
, idx
);
2232 if (!VECTORP (slot
))
2233 /* This is the first unsed slot. Register NAME here. */
2236 if (EQ (name
, AREF (slot
, 0)))
2238 /* Update this slot. */
2239 ASET (slot
, 1, ccl_prog
);
2240 ASET (slot
, 2, resolved
);
2242 return make_number (idx
);
2248 /* Extend the table. */
2249 Lisp_Object new_table
;
2252 new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
2253 for (j
= 0; j
< len
; j
++)
2254 ASET (new_table
, j
, AREF (Vccl_program_table
, j
));
2255 Vccl_program_table
= new_table
;
2261 elt
= Fmake_vector (make_number (4), Qnil
);
2262 ASET (elt
, 0, name
);
2263 ASET (elt
, 1, ccl_prog
);
2264 ASET (elt
, 2, resolved
);
2266 ASET (Vccl_program_table
, idx
, elt
);
2269 Fput (name
, Qccl_program_idx
, make_number (idx
));
2270 return make_number (idx
);
2273 /* Register code conversion map.
2274 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
2275 The first element is the start code point.
2276 The other elements are mapped numbers.
2277 Symbol t means to map to an original number before mapping.
2278 Symbol nil means that the corresponding element is empty.
2279 Symbol lambda means to terminate mapping here.
2282 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map
,
2283 Sregister_code_conversion_map
,
2285 doc
: /* Register SYMBOL as code conversion map MAP.
2286 Return index number of the registered map. */)
2288 Lisp_Object symbol
, map
;
2290 int len
= ASIZE (Vcode_conversion_map_vector
);
2294 CHECK_SYMBOL (symbol
);
2297 for (i
= 0; i
< len
; i
++)
2299 Lisp_Object slot
= AREF (Vcode_conversion_map_vector
, i
);
2304 if (EQ (symbol
, XCAR (slot
)))
2306 index
= make_number (i
);
2307 XSETCDR (slot
, map
);
2308 Fput (symbol
, Qcode_conversion_map
, map
);
2309 Fput (symbol
, Qcode_conversion_map_id
, index
);
2316 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
2319 for (j
= 0; j
< len
; j
++)
2320 AREF (new_vector
, j
)
2321 = AREF (Vcode_conversion_map_vector
, j
);
2322 Vcode_conversion_map_vector
= new_vector
;
2325 index
= make_number (i
);
2326 Fput (symbol
, Qcode_conversion_map
, map
);
2327 Fput (symbol
, Qcode_conversion_map_id
, index
);
2328 AREF (Vcode_conversion_map_vector
, i
) = Fcons (symbol
, map
);
2336 staticpro (&Vccl_program_table
);
2337 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
2339 Qccl
= intern ("ccl");
2342 Qcclp
= intern ("cclp");
2345 Qccl_program
= intern ("ccl-program");
2346 staticpro (&Qccl_program
);
2348 Qccl_program_idx
= intern ("ccl-program-idx");
2349 staticpro (&Qccl_program_idx
);
2351 Qcode_conversion_map
= intern ("code-conversion-map");
2352 staticpro (&Qcode_conversion_map
);
2354 Qcode_conversion_map_id
= intern ("code-conversion-map-id");
2355 staticpro (&Qcode_conversion_map_id
);
2357 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector
,
2358 doc
: /* Vector of code conversion maps. */);
2359 Vcode_conversion_map_vector
= Fmake_vector (make_number (16), Qnil
);
2361 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
2362 doc
: /* Alist of fontname patterns vs corresponding CCL program.
2363 Each element looks like (REGEXP . CCL-CODE),
2364 where CCL-CODE is a compiled CCL program.
2365 When a font whose name matches REGEXP is used for displaying a character,
2366 CCL-CODE is executed to calculate the code point in the font
2367 from the charset number and position code(s) of the character which are set
2368 in CCL registers R0, R1, and R2 before the execution.
2369 The code point in the font is set in CCL registers R1 and R2
2370 when the execution terminated.
2371 If the font is single-byte font, the register R2 is not used. */);
2372 Vfont_ccl_encoder_alist
= Qnil
;
2374 DEFVAR_LISP ("translation-hash-table-vector", &Vtranslation_hash_table_vector
,
2375 doc
: /* Vector containing all translation hash tables ever defined.
2376 Comprises pairs (SYMBOL . TABLE) where SYMBOL and TABLE were set up by calls
2377 to `define-translation-hash-table'. The vector is indexed by the table id
2379 Vtranslation_hash_table_vector
= Qnil
;
2381 defsubr (&Sccl_program_p
);
2382 defsubr (&Sccl_execute
);
2383 defsubr (&Sccl_execute_on_string
);
2384 defsubr (&Sregister_ccl_program
);
2385 defsubr (&Sregister_code_conversion_map
);
2388 /* arch-tag: bb9a37be-68ce-4576-8d3d-15d750e4a860
2389 (do not change this comment) */