1 /* CCL (Code Conversion Language) interpreter.
2 Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
3 Copyright (C) 2001 Free Software Foundation, Inc.
4 Licensed to the Free Software Foundation.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
40 #endif /* not emacs */
42 /* This contains all code conversion map available to CCL. */
43 Lisp_Object Vcode_conversion_map_vector
;
45 /* Alist of fontname patterns vs corresponding CCL program. */
46 Lisp_Object Vfont_ccl_encoder_alist
;
48 /* This symbol is a property which assocates with ccl program vector.
49 Ex: (get 'ccl-big5-encoder 'ccl-program) returns ccl program vector. */
50 Lisp_Object Qccl_program
;
52 /* These symbols are properties which associate with code conversion
53 map and their ID respectively. */
54 Lisp_Object Qcode_conversion_map
;
55 Lisp_Object Qcode_conversion_map_id
;
57 /* Symbols of ccl program have this property, a value of the property
58 is an index for Vccl_protram_table. */
59 Lisp_Object Qccl_program_idx
;
61 /* Table of registered CCL programs. Each element is a vector of
62 NAME, CCL_PROG, and RESOLVEDP where NAME (symbol) is the name of
63 the program, CCL_PROG (vector) is the compiled code of the program,
64 RESOLVEDP (t or nil) is the flag to tell if symbols in CCL_PROG is
65 already resolved to index numbers or not. */
66 Lisp_Object Vccl_program_table
;
68 /* CCL (Code Conversion Language) is a simple language which has
69 operations on one input buffer, one output buffer, and 7 registers.
70 The syntax of CCL is described in `ccl.el'. Emacs Lisp function
71 `ccl-compile' compiles a CCL program and produces a CCL code which
72 is a vector of integers. The structure of this vector is as
73 follows: The 1st element: buffer-magnification, a factor for the
74 size of output buffer compared with the size of input buffer. The
75 2nd element: address of CCL code to be executed when encountered
76 with end of input stream. The 3rd and the remaining elements: CCL
79 /* Header of CCL compiled code */
80 #define CCL_HEADER_BUF_MAG 0
81 #define CCL_HEADER_EOF 1
82 #define CCL_HEADER_MAIN 2
84 /* CCL code is a sequence of 28-bit non-negative integers (i.e. the
85 MSB is always 0), each contains CCL command and/or arguments in the
88 |----------------- integer (28-bit) ------------------|
89 |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
90 |--constant argument--|-register-|-register-|-command-|
91 ccccccccccccccccc RRR rrr XXXXX
93 |------- relative address -------|-register-|-command-|
94 cccccccccccccccccccc rrr XXXXX
96 |------------- constant or other args ----------------|
97 cccccccccccccccccccccccccccc
99 where, `cc...c' is a non-negative integer indicating constant value
100 (the left most `c' is always 0) or an absolute jump address, `RRR'
101 and `rrr' are CCL register number, `XXXXX' is one of the following
106 Each comment fields shows one or more lines for command syntax and
107 the following lines for semantics of the command. In semantics, IC
108 stands for Instruction Counter. */
110 #define CCL_SetRegister 0x00 /* Set register a register value:
111 1:00000000000000000RRRrrrXXXXX
112 ------------------------------
116 #define CCL_SetShortConst 0x01 /* Set register a short constant value:
117 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
118 ------------------------------
119 reg[rrr] = CCCCCCCCCCCCCCCCCCC;
122 #define CCL_SetConst 0x02 /* Set register a constant value:
123 1:00000000000000000000rrrXXXXX
125 ------------------------------
130 #define CCL_SetArray 0x03 /* Set register an element of array:
131 1:CCCCCCCCCCCCCCCCCRRRrrrXXXXX
135 ------------------------------
136 if (0 <= reg[RRR] < CC..C)
137 reg[rrr] = ELEMENT[reg[RRR]];
141 #define CCL_Jump 0x04 /* Jump:
142 1:A--D--D--R--E--S--S-000XXXXX
143 ------------------------------
147 /* Note: If CC..C is greater than 0, the second code is omitted. */
149 #define CCL_JumpCond 0x05 /* Jump conditional:
150 1:A--D--D--R--E--S--S-rrrXXXXX
151 ------------------------------
157 #define CCL_WriteRegisterJump 0x06 /* Write register and jump:
158 1:A--D--D--R--E--S--S-rrrXXXXX
159 ------------------------------
164 #define CCL_WriteRegisterReadJump 0x07 /* Write register, read, and jump:
165 1:A--D--D--R--E--S--S-rrrXXXXX
166 2:A--D--D--R--E--S--S-rrrYYYYY
167 -----------------------------
173 /* Note: If read is suspended, the resumed execution starts from the
174 second code (YYYYY == CCL_ReadJump). */
176 #define CCL_WriteConstJump 0x08 /* Write constant and jump:
177 1:A--D--D--R--E--S--S-000XXXXX
179 ------------------------------
184 #define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump:
185 1:A--D--D--R--E--S--S-rrrXXXXX
187 3:A--D--D--R--E--S--S-rrrYYYYY
188 -----------------------------
194 /* Note: If read is suspended, the resumed execution starts from the
195 second code (YYYYY == CCL_ReadJump). */
197 #define CCL_WriteStringJump 0x0A /* Write string and jump:
198 1:A--D--D--R--E--S--S-000XXXXX
200 3:0000STRIN[0]STRIN[1]STRIN[2]
202 ------------------------------
203 write_string (STRING, LENGTH);
207 #define CCL_WriteArrayReadJump 0x0B /* Write an array element, read, and jump:
208 1:A--D--D--R--E--S--S-rrrXXXXX
213 N:A--D--D--R--E--S--S-rrrYYYYY
214 ------------------------------
215 if (0 <= reg[rrr] < LENGTH)
216 write (ELEMENT[reg[rrr]]);
217 IC += LENGTH + 2; (... pointing at N+1)
221 /* Note: If read is suspended, the resumed execution starts from the
222 Nth code (YYYYY == CCL_ReadJump). */
224 #define CCL_ReadJump 0x0C /* Read and jump:
225 1:A--D--D--R--E--S--S-rrrYYYYY
226 -----------------------------
231 #define CCL_Branch 0x0D /* Jump by branch table:
232 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
233 2:A--D--D--R--E-S-S[0]000XXXXX
234 3:A--D--D--R--E-S-S[1]000XXXXX
236 ------------------------------
237 if (0 <= reg[rrr] < CC..C)
238 IC += ADDRESS[reg[rrr]];
240 IC += ADDRESS[CC..C];
243 #define CCL_ReadRegister 0x0E /* Read bytes into registers:
244 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
245 2:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
247 ------------------------------
252 #define CCL_WriteExprConst 0x0F /* write result of expression:
253 1:00000OPERATION000RRR000XXXXX
255 ------------------------------
256 write (reg[RRR] OPERATION CONSTANT);
260 /* Note: If the Nth read is suspended, the resumed execution starts
261 from the Nth code. */
263 #define CCL_ReadBranch 0x10 /* Read one byte into a register,
264 and jump by branch table:
265 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
266 2:A--D--D--R--E-S-S[0]000XXXXX
267 3:A--D--D--R--E-S-S[1]000XXXXX
269 ------------------------------
271 if (0 <= reg[rrr] < CC..C)
272 IC += ADDRESS[reg[rrr]];
274 IC += ADDRESS[CC..C];
277 #define CCL_WriteRegister 0x11 /* Write registers:
278 1:CCCCCCCCCCCCCCCCCCCrrrXXXXX
279 2:CCCCCCCCCCCCCCCCCCCrrrXXXXX
281 ------------------------------
287 /* Note: If the Nth write is suspended, the resumed execution
288 starts from the Nth code. */
290 #define CCL_WriteExprRegister 0x12 /* Write result of expression
291 1:00000OPERATIONRrrRRR000XXXXX
292 ------------------------------
293 write (reg[RRR] OPERATION reg[Rrr]);
296 #define CCL_Call 0x13 /* Call the CCL program whose ID is
298 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX
299 [2:00000000cccccccccccccccccccc]
300 ------------------------------
308 #define CCL_WriteConstString 0x14 /* Write a constant or a string:
309 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
310 [2:0000STRIN[0]STRIN[1]STRIN[2]]
312 -----------------------------
316 write_string (STRING, CC..C);
317 IC += (CC..C + 2) / 3;
320 #define CCL_WriteArray 0x15 /* Write an element of array:
321 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
325 ------------------------------
326 if (0 <= reg[rrr] < CC..C)
327 write (ELEMENT[reg[rrr]]);
331 #define CCL_End 0x16 /* Terminate:
332 1:00000000000000000000000XXXXX
333 ------------------------------
337 /* The following two codes execute an assignment arithmetic/logical
338 operation. The form of the operation is like REG OP= OPERAND. */
340 #define CCL_ExprSelfConst 0x17 /* REG OP= constant:
341 1:00000OPERATION000000rrrXXXXX
343 ------------------------------
344 reg[rrr] OPERATION= CONSTANT;
347 #define CCL_ExprSelfReg 0x18 /* REG1 OP= REG2:
348 1:00000OPERATION000RRRrrrXXXXX
349 ------------------------------
350 reg[rrr] OPERATION= reg[RRR];
353 /* The following codes execute an arithmetic/logical operation. The
354 form of the operation is like REG_X = REG_Y OP OPERAND2. */
356 #define CCL_SetExprConst 0x19 /* REG_X = REG_Y OP constant:
357 1:00000OPERATION000RRRrrrXXXXX
359 ------------------------------
360 reg[rrr] = reg[RRR] OPERATION CONSTANT;
364 #define CCL_SetExprReg 0x1A /* REG1 = REG2 OP REG3:
365 1:00000OPERATIONRrrRRRrrrXXXXX
366 ------------------------------
367 reg[rrr] = reg[RRR] OPERATION reg[Rrr];
370 #define CCL_JumpCondExprConst 0x1B /* Jump conditional according to
371 an operation on constant:
372 1:A--D--D--R--E--S--S-rrrXXXXX
375 -----------------------------
376 reg[7] = reg[rrr] OPERATION CONSTANT;
383 #define CCL_JumpCondExprReg 0x1C /* Jump conditional according to
384 an operation on register:
385 1:A--D--D--R--E--S--S-rrrXXXXX
388 -----------------------------
389 reg[7] = reg[rrr] OPERATION reg[RRR];
396 #define CCL_ReadJumpCondExprConst 0x1D /* Read and jump conditional according
397 to an operation on constant:
398 1:A--D--D--R--E--S--S-rrrXXXXX
401 -----------------------------
403 reg[7] = reg[rrr] OPERATION CONSTANT;
410 #define CCL_ReadJumpCondExprReg 0x1E /* Read and jump conditional according
411 to an operation on register:
412 1:A--D--D--R--E--S--S-rrrXXXXX
415 -----------------------------
417 reg[7] = reg[rrr] OPERATION reg[RRR];
424 #define CCL_Extension 0x1F /* Extended CCL code
425 1:ExtendedCOMMNDRrrRRRrrrXXXXX
428 ------------------------------
429 extended_command (rrr,RRR,Rrr,ARGS)
433 Here after, Extended CCL Instructions.
434 Bit length of extended command is 14.
435 Therefore, the instruction code range is 0..16384(0x3fff).
438 /* Read a multibyte characeter.
439 A code point is stored into reg[rrr]. A charset ID is stored into
442 #define CCL_ReadMultibyteChar2 0x00 /* Read Multibyte Character
443 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
445 /* Write a multibyte character.
446 Write a character whose code point is reg[rrr] and the charset ID
449 #define CCL_WriteMultibyteChar2 0x01 /* Write Multibyte Character
450 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
452 /* Translate a character whose code point is reg[rrr] and the charset
453 ID is reg[RRR] by a translation table whose ID is reg[Rrr].
455 A translated character is set in reg[rrr] (code point) and reg[RRR]
458 #define CCL_TranslateCharacter 0x02 /* Translate a multibyte character
459 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
461 /* Translate a character whose code point is reg[rrr] and the charset
462 ID is reg[RRR] by a translation table whose ID is ARGUMENT.
464 A translated character is set in reg[rrr] (code point) and reg[RRR]
467 #define CCL_TranslateCharacterConstTbl 0x03 /* Translate a multibyte character
468 1:ExtendedCOMMNDRrrRRRrrrXXXXX
469 2:ARGUMENT(Translation Table ID)
472 /* Iterate looking up MAPs for reg[rrr] starting from the Nth (N =
473 reg[RRR]) MAP until some value is found.
475 Each MAP is a Lisp vector whose element is number, nil, t, or
477 If the element is nil, ignore the map and proceed to the next map.
478 If the element is t or lambda, finish without changing reg[rrr].
479 If the element is a number, set reg[rrr] to the number and finish.
481 Detail of the map structure is descibed in the comment for
482 CCL_MapMultiple below. */
484 #define CCL_IterateMultipleMap 0x10 /* Iterate multiple maps
485 1:ExtendedCOMMNDXXXRRRrrrXXXXX
492 /* Map the code in reg[rrr] by MAPs starting from the Nth (N =
495 MAPs are supplied in the succeeding CCL codes as follows:
497 When CCL program gives this nested structure of map to this command:
500 (MAP-ID121 MAP-ID122 MAP-ID123)
503 (MAP-ID211 (MAP-ID2111) MAP-ID212)
505 the compiled CCL codes has this sequence:
506 CCL_MapMultiple (CCL code of this command)
507 16 (total number of MAPs and SEPARATORs)
525 A value of each SEPARATOR follows this rule:
526 MAP-SET := SEPARATOR [(MAP-ID | MAP-SET)]+
527 SEPARATOR := -(number of MAP-IDs and SEPARATORs in the MAP-SET)
529 (*)....Nest level of MAP-SET must not be over than MAX_MAP_SET_LEVEL.
531 When some map fails to map (i.e. it doesn't have a value for
532 reg[rrr]), the mapping is treated as identity.
534 The mapping is iterated for all maps in each map set (set of maps
535 separated by SEPARATOR) except in the case that lambda is
536 encountered. More precisely, the mapping proceeds as below:
538 At first, VAL0 is set to reg[rrr], and it is translated by the
539 first map to VAL1. Then, VAL1 is translated by the next map to
540 VAL2. This mapping is iterated until the last map is used. The
541 result of the mapping is the last value of VAL?. When the mapping
542 process reached to the end of the map set, it moves to the next
543 map set. If the next does not exit, the mapping process terminates,
544 and regard the last value as a result.
546 But, when VALm is mapped to VALn and VALn is not a number, the
547 mapping proceed as below:
549 If VALn is nil, the lastest map is ignored and the mapping of VALm
550 proceed to the next map.
552 In VALn is t, VALm is reverted to reg[rrr] and the mapping of VALm
553 proceed to the next map.
555 If VALn is lambda, move to the next map set like reaching to the
556 end of the current map set.
558 If VALn is a symbol, call the CCL program refered by it.
559 Then, use reg[rrr] as a mapped value except for -1, -2 and -3.
560 Such special values are regarded as nil, t, and lambda respectively.
562 Each map is a Lisp vector of the following format (a) or (b):
563 (a)......[STARTPOINT VAL1 VAL2 ...]
564 (b)......[t VAL STARTPOINT ENDPOINT],
566 STARTPOINT is an offset to be used for indexing a map,
567 ENDPOINT is a maximum index number of a map,
568 VAL and VALn is a number, nil, t, or lambda.
570 Valid index range of a map of type (a) is:
571 STARTPOINT <= index < STARTPOINT + map_size - 1
572 Valid index range of a map of type (b) is:
573 STARTPOINT <= index < ENDPOINT */
575 #define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
576 1:ExtendedCOMMNDXXXRRRrrrXXXXX
588 #define MAX_MAP_SET_LEVEL 30
596 static tr_stack mapping_stack
[MAX_MAP_SET_LEVEL
];
597 static tr_stack
*mapping_stack_pointer
;
599 /* If this variable is non-zero, it indicates the stack_idx
600 of immediately called by CCL_MapMultiple. */
601 static int stack_idx_of_map_multiple
;
603 #define PUSH_MAPPING_STACK(restlen, orig) \
606 mapping_stack_pointer->rest_length = (restlen); \
607 mapping_stack_pointer->orig_val = (orig); \
608 mapping_stack_pointer++; \
612 #define POP_MAPPING_STACK(restlen, orig) \
615 mapping_stack_pointer--; \
616 (restlen) = mapping_stack_pointer->rest_length; \
617 (orig) = mapping_stack_pointer->orig_val; \
621 #define CCL_CALL_FOR_MAP_INSTRUCTION(symbol, ret_ic) \
624 struct ccl_program called_ccl; \
625 if (stack_idx >= 256 \
626 || (setup_ccl_program (&called_ccl, (symbol)) != 0)) \
630 ccl_prog = ccl_prog_stack_struct[0].ccl_prog; \
631 ic = ccl_prog_stack_struct[0].ic; \
635 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; \
636 ccl_prog_stack_struct[stack_idx].ic = (ret_ic); \
638 ccl_prog = called_ccl.prog; \
639 ic = CCL_HEADER_MAIN; \
644 #define CCL_MapSingle 0x12 /* Map by single code conversion map
645 1:ExtendedCOMMNDXXXRRRrrrXXXXX
647 ------------------------------
648 Map reg[rrr] by MAP-ID.
649 If some valid mapping is found,
650 set reg[rrr] to the result,
655 /* CCL arithmetic/logical operators. */
656 #define CCL_PLUS 0x00 /* X = Y + Z */
657 #define CCL_MINUS 0x01 /* X = Y - Z */
658 #define CCL_MUL 0x02 /* X = Y * Z */
659 #define CCL_DIV 0x03 /* X = Y / Z */
660 #define CCL_MOD 0x04 /* X = Y % Z */
661 #define CCL_AND 0x05 /* X = Y & Z */
662 #define CCL_OR 0x06 /* X = Y | Z */
663 #define CCL_XOR 0x07 /* X = Y ^ Z */
664 #define CCL_LSH 0x08 /* X = Y << Z */
665 #define CCL_RSH 0x09 /* X = Y >> Z */
666 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
667 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
668 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
669 #define CCL_LS 0x10 /* X = (X < Y) */
670 #define CCL_GT 0x11 /* X = (X > Y) */
671 #define CCL_EQ 0x12 /* X = (X == Y) */
672 #define CCL_LE 0x13 /* X = (X <= Y) */
673 #define CCL_GE 0x14 /* X = (X >= Y) */
674 #define CCL_NE 0x15 /* X = (X != Y) */
676 #define CCL_DECODE_SJIS 0x16 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
677 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
678 #define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z))
679 r[7] = LOWER_BYTE (SJIS (Y, Z) */
681 /* Terminate CCL program successfully. */
682 #define CCL_SUCCESS \
685 ccl->status = CCL_STAT_SUCCESS; \
690 /* Suspend CCL program because of reading from empty input buffer or
691 writing to full output buffer. When this program is resumed, the
692 same I/O command is executed. */
693 #define CCL_SUSPEND(stat) \
697 ccl->status = stat; \
702 /* Terminate CCL program because of invalid command. Should not occur
703 in the normal case. */
704 #define CCL_INVALID_CMD \
707 ccl->status = CCL_STAT_INVALID_CMD; \
708 goto ccl_error_handler; \
712 /* Encode one character CH to multibyte form and write to the current
713 output buffer. If CH is less than 256, CH is written as is. */
714 #define CCL_WRITE_CHAR(ch) \
716 int bytes = SINGLE_BYTE_CHAR_P (ch) ? 1: CHAR_BYTES (ch); \
719 else if (dst + bytes + extra_bytes < (dst_bytes ? dst_end : src)) \
724 if ((ch) >= 0x80 && (ch) < 0xA0) \
725 /* We may have to convert this eight-bit char to \
726 multibyte form later. */ \
729 else if (CHAR_VALID_P (ch, 0)) \
730 dst += CHAR_STRING (ch, dst); \
735 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
738 /* Encode one character CH to multibyte form and write to the current
739 output buffer. The output bytes always forms a valid multibyte
741 #define CCL_WRITE_MULTIBYTE_CHAR(ch) \
743 int bytes = CHAR_BYTES (ch); \
746 else if (dst + bytes + extra_bytes < (dst_bytes ? dst_end : src)) \
748 if (CHAR_VALID_P ((ch), 0)) \
749 dst += CHAR_STRING ((ch), dst); \
754 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
757 /* Write a string at ccl_prog[IC] of length LEN to the current output
759 #define CCL_WRITE_STRING(len) \
763 else if (dst + len <= (dst_bytes ? dst_end : src)) \
764 for (i = 0; i < len; i++) \
765 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
766 >> ((2 - (i % 3)) * 8)) & 0xFF; \
768 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
771 /* Read one byte from the current input buffer into REGth register. */
772 #define CCL_READ_CHAR(REG) \
776 else if (src < src_end) \
780 && ccl->eol_type != CODING_EOL_LF) \
782 /* We are encoding. */ \
783 if (ccl->eol_type == CODING_EOL_CRLF) \
785 if (ccl->cr_consumed) \
786 ccl->cr_consumed = 0; \
789 ccl->cr_consumed = 1; \
797 if (REG == LEADING_CODE_8_BIT_CONTROL \
799 REG = *src++ - 0x20; \
801 else if (ccl->last_block) \
807 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
811 /* Set C to the character code made from CHARSET and CODE. This is
812 like MAKE_CHAR but check the validity of CHARSET and CODE. If they
813 are not valid, set C to (CODE & 0xFF) because that is usually the
814 case that CCL_ReadMultibyteChar2 read an invalid code and it set
815 CODE to that invalid byte. */
817 #define CCL_MAKE_CHAR(charset, code, c) \
819 if (charset == CHARSET_ASCII) \
821 else if (CHARSET_DEFINED_P (charset) \
822 && (code & 0x7F) >= 32 \
823 && (code < 256 || ((code >> 7) & 0x7F) >= 32)) \
825 int c1 = code & 0x7F, c2 = 0; \
828 c2 = c1, c1 = (code >> 7) & 0x7F; \
829 c = MAKE_CHAR (charset, c1, c2); \
836 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
837 text goes to a place pointed by DESTINATION, the length of which
838 should not exceed DST_BYTES. The bytes actually processed is
839 returned as *CONSUMED. The return value is the length of the
840 resulting text. As a side effect, the contents of CCL registers
841 are updated. If SOURCE or DESTINATION is NULL, only operations on
842 registers are permitted. */
845 #define CCL_DEBUG_BACKTRACE_LEN 256
846 int ccl_backtrace_table
[CCL_BACKTRACE_TABLE
];
847 int ccl_backtrace_idx
;
850 struct ccl_prog_stack
852 Lisp_Object
*ccl_prog
; /* Pointer to an array of CCL code. */
853 int ic
; /* Instruction Counter. */
856 /* For the moment, we only support depth 256 of stack. */
857 static struct ccl_prog_stack ccl_prog_stack_struct
[256];
860 ccl_driver (ccl
, source
, destination
, src_bytes
, dst_bytes
, consumed
)
861 struct ccl_program
*ccl
;
862 unsigned char *source
, *destination
;
863 int src_bytes
, dst_bytes
;
866 register int *reg
= ccl
->reg
;
867 register int ic
= ccl
->ic
;
868 register int code
= 0, field1
, field2
;
869 register Lisp_Object
*ccl_prog
= ccl
->prog
;
870 unsigned char *src
= source
, *src_end
= src
+ src_bytes
;
871 unsigned char *dst
= destination
, *dst_end
= dst
+ dst_bytes
;
874 int stack_idx
= ccl
->stack_idx
;
875 /* Instruction counter of the current CCL code. */
877 /* CCL_WRITE_CHAR will produce 8-bit code of range 0x80..0x9F. But,
878 each of them will be converted to multibyte form of 2-byte
879 sequence. For that conversion, we remember how many more bytes
880 we must keep in DESTINATION in this variable. */
883 if (ic
>= ccl
->eof_ic
)
884 ic
= CCL_HEADER_MAIN
;
886 if (ccl
->buf_magnification
== 0) /* We can't produce any bytes. */
889 /* Set mapping stack pointer. */
890 mapping_stack_pointer
= mapping_stack
;
893 ccl_backtrace_idx
= 0;
900 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
901 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
902 ccl_backtrace_idx
= 0;
903 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
906 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
908 /* We can't just signal Qquit, instead break the loop as if
909 the whole data is processed. Don't reset Vquit_flag, it
910 must be handled later at a safer place. */
912 src
= source
+ src_bytes
;
913 ccl
->status
= CCL_STAT_QUIT
;
918 code
= XINT (ccl_prog
[ic
]); ic
++;
920 field2
= (code
& 0xFF) >> 5;
923 #define RRR (field1 & 7)
924 #define Rrr ((field1 >> 3) & 7)
926 #define EXCMD (field1 >> 6)
930 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
934 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
938 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
939 reg
[rrr
] = XINT (ccl_prog
[ic
]);
943 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
946 if ((unsigned int) i
< j
)
947 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
951 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
955 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
960 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
966 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
970 CCL_READ_CHAR (reg
[rrr
]);
974 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
975 i
= XINT (ccl_prog
[ic
]);
980 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
981 i
= XINT (ccl_prog
[ic
]);
984 CCL_READ_CHAR (reg
[rrr
]);
988 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
989 j
= XINT (ccl_prog
[ic
]);
991 CCL_WRITE_STRING (j
);
995 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
997 j
= XINT (ccl_prog
[ic
]);
998 if ((unsigned int) i
< j
)
1000 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
1004 CCL_READ_CHAR (reg
[rrr
]);
1005 ic
+= ADDR
- (j
+ 2);
1008 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
1009 CCL_READ_CHAR (reg
[rrr
]);
1013 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1014 CCL_READ_CHAR (reg
[rrr
]);
1015 /* fall through ... */
1016 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1017 if ((unsigned int) reg
[rrr
] < field1
)
1018 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
1020 ic
+= XINT (ccl_prog
[ic
+ field1
]);
1023 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
1026 CCL_READ_CHAR (reg
[rrr
]);
1028 code
= XINT (ccl_prog
[ic
]); ic
++;
1030 field2
= (code
& 0xFF) >> 5;
1034 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
1037 j
= XINT (ccl_prog
[ic
]);
1039 jump_address
= ic
+ 1;
1042 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
1048 code
= XINT (ccl_prog
[ic
]); ic
++;
1050 field2
= (code
& 0xFF) >> 5;
1054 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
1062 case CCL_Call
: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
1067 /* If FFF is nonzero, the CCL program ID is in the
1071 prog_id
= XINT (ccl_prog
[ic
]);
1077 if (stack_idx
>= 256
1079 || prog_id
>= XVECTOR (Vccl_program_table
)->size
1080 || (slot
= XVECTOR (Vccl_program_table
)->contents
[prog_id
],
1082 || !VECTORP (XVECTOR (slot
)->contents
[1]))
1086 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
1087 ic
= ccl_prog_stack_struct
[0].ic
;
1092 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
1093 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
1095 ccl_prog
= XVECTOR (XVECTOR (slot
)->contents
[1])->contents
;
1096 ic
= CCL_HEADER_MAIN
;
1100 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1102 CCL_WRITE_CHAR (field1
);
1105 CCL_WRITE_STRING (field1
);
1106 ic
+= (field1
+ 2) / 3;
1110 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1112 if ((unsigned int) i
< field1
)
1114 j
= XINT (ccl_prog
[ic
+ i
]);
1120 case CCL_End
: /* 0000000000000000000000XXXXX */
1124 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
1125 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
1130 /* ccl->ic should points to this command code again to
1131 suppress further processing. */
1135 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
1136 i
= XINT (ccl_prog
[ic
]);
1141 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
1148 case CCL_PLUS
: reg
[rrr
] += i
; break;
1149 case CCL_MINUS
: reg
[rrr
] -= i
; break;
1150 case CCL_MUL
: reg
[rrr
] *= i
; break;
1151 case CCL_DIV
: reg
[rrr
] /= i
; break;
1152 case CCL_MOD
: reg
[rrr
] %= i
; break;
1153 case CCL_AND
: reg
[rrr
] &= i
; break;
1154 case CCL_OR
: reg
[rrr
] |= i
; break;
1155 case CCL_XOR
: reg
[rrr
] ^= i
; break;
1156 case CCL_LSH
: reg
[rrr
] <<= i
; break;
1157 case CCL_RSH
: reg
[rrr
] >>= i
; break;
1158 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
1159 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
1160 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
1161 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
1162 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
1163 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
1164 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
1165 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
1166 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
1167 default: CCL_INVALID_CMD
;
1171 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1173 j
= XINT (ccl_prog
[ic
]);
1175 jump_address
= ++ic
;
1178 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1185 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1186 CCL_READ_CHAR (reg
[rrr
]);
1187 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1189 op
= XINT (ccl_prog
[ic
]);
1190 jump_address
= ic
++ + ADDR
;
1191 j
= XINT (ccl_prog
[ic
]);
1196 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1197 CCL_READ_CHAR (reg
[rrr
]);
1198 case CCL_JumpCondExprReg
:
1200 op
= XINT (ccl_prog
[ic
]);
1201 jump_address
= ic
++ + ADDR
;
1202 j
= reg
[XINT (ccl_prog
[ic
])];
1209 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1210 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1211 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1212 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1213 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1214 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1215 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1216 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1217 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1218 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1219 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1220 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1221 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1222 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1223 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1224 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1225 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1226 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1227 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1228 case CCL_DECODE_SJIS
: DECODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1229 case CCL_ENCODE_SJIS
: ENCODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1230 default: CCL_INVALID_CMD
;
1233 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1246 case CCL_ReadMultibyteChar2
:
1253 goto ccl_read_multibyte_character_suspend
;
1256 if (!ccl
->multibyte
)
1259 if (!UNIBYTE_STR_AS_MULTIBYTE_P (src
, src_end
- src
, bytes
))
1261 reg
[RRR
] = CHARSET_8_BIT_CONTROL
;
1267 if (i
== '\n' && ccl
->eol_type
!= CODING_EOL_LF
)
1269 /* We are encoding. */
1270 if (ccl
->eol_type
== CODING_EOL_CRLF
)
1272 if (ccl
->cr_consumed
)
1273 ccl
->cr_consumed
= 0;
1276 ccl
->cr_consumed
= 1;
1284 reg
[RRR
] = CHARSET_ASCII
;
1290 reg
[RRR
] = CHARSET_ASCII
;
1292 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION2
)
1294 int dimension
= BYTES_BY_CHAR_HEAD (i
) - 1;
1298 /* `i' is a leading code for an undefined charset. */
1299 reg
[RRR
] = CHARSET_8_BIT_GRAPHIC
;
1302 else if (src
+ dimension
> src_end
)
1303 goto ccl_read_multibyte_character_suspend
;
1307 i
= (*src
++ & 0x7F);
1311 reg
[rrr
] = ((i
<< 7) | (*src
++ & 0x7F));
1314 else if ((i
== LEADING_CODE_PRIVATE_11
)
1315 || (i
== LEADING_CODE_PRIVATE_12
))
1317 if ((src
+ 1) >= src_end
)
1318 goto ccl_read_multibyte_character_suspend
;
1320 reg
[rrr
] = (*src
++ & 0x7F);
1322 else if ((i
== LEADING_CODE_PRIVATE_21
)
1323 || (i
== LEADING_CODE_PRIVATE_22
))
1325 if ((src
+ 2) >= src_end
)
1326 goto ccl_read_multibyte_character_suspend
;
1328 i
= (*src
++ & 0x7F);
1329 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1332 else if (i
== LEADING_CODE_8_BIT_CONTROL
)
1335 goto ccl_read_multibyte_character_suspend
;
1336 reg
[RRR
] = CHARSET_8_BIT_CONTROL
;
1337 reg
[rrr
] = (*src
++ - 0x20);
1341 reg
[RRR
] = CHARSET_8_BIT_GRAPHIC
;
1346 /* INVALID CODE. Return a single byte character. */
1347 reg
[RRR
] = CHARSET_ASCII
;
1352 ccl_read_multibyte_character_suspend
:
1353 if (src
<= src_end
&& !ccl
->multibyte
&& ccl
->last_block
)
1355 reg
[RRR
] = CHARSET_8_BIT_CONTROL
;
1360 if (ccl
->last_block
)
1366 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC
);
1370 case CCL_WriteMultibyteChar2
:
1371 i
= reg
[RRR
]; /* charset */
1372 if (i
== CHARSET_ASCII
1373 || i
== CHARSET_8_BIT_CONTROL
1374 || i
== CHARSET_8_BIT_GRAPHIC
)
1375 i
= reg
[rrr
] & 0xFF;
1376 else if (CHARSET_DIMENSION (i
) == 1)
1377 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1378 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1379 i
= ((i
- 0x8F) << 14) | reg
[rrr
];
1381 i
= ((i
- 0xE0) << 14) | reg
[rrr
];
1383 CCL_WRITE_MULTIBYTE_CHAR (i
);
1387 case CCL_TranslateCharacter
:
1388 CCL_MAKE_CHAR (reg
[RRR
], reg
[rrr
], i
);
1389 op
= translate_char (GET_TRANSLATION_TABLE (reg
[Rrr
]),
1391 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1398 case CCL_TranslateCharacterConstTbl
:
1399 op
= XINT (ccl_prog
[ic
]); /* table */
1401 CCL_MAKE_CHAR (reg
[RRR
], reg
[rrr
], i
);
1402 op
= translate_char (GET_TRANSLATION_TABLE (op
), i
, -1, 0, 0);
1403 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1410 case CCL_IterateMultipleMap
:
1412 Lisp_Object map
, content
, attrib
, value
;
1413 int point
, size
, fin_ic
;
1415 j
= XINT (ccl_prog
[ic
++]); /* number of maps. */
1418 if ((j
> reg
[RRR
]) && (j
>= 0))
1433 size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1434 point
= XINT (ccl_prog
[ic
++]);
1435 if (point
>= size
) continue;
1437 XVECTOR (Vcode_conversion_map_vector
)->contents
[point
];
1439 /* Check map varidity. */
1440 if (!CONSP (map
)) continue;
1442 if (!VECTORP (map
)) continue;
1443 size
= XVECTOR (map
)->size
;
1444 if (size
<= 1) continue;
1446 content
= XVECTOR (map
)->contents
[0];
1449 [STARTPOINT VAL1 VAL2 ...] or
1450 [t ELELMENT STARTPOINT ENDPOINT] */
1451 if (NUMBERP (content
))
1453 point
= XUINT (content
);
1454 point
= op
- point
+ 1;
1455 if (!((point
>= 1) && (point
< size
))) continue;
1456 content
= XVECTOR (map
)->contents
[point
];
1458 else if (EQ (content
, Qt
))
1460 if (size
!= 4) continue;
1461 if ((op
>= XUINT (XVECTOR (map
)->contents
[2]))
1462 && (op
< XUINT (XVECTOR (map
)->contents
[3])))
1463 content
= XVECTOR (map
)->contents
[1];
1472 else if (NUMBERP (content
))
1475 reg
[rrr
] = XINT(content
);
1478 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1483 else if (CONSP (content
))
1485 attrib
= XCAR (content
);
1486 value
= XCDR (content
);
1487 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1490 reg
[rrr
] = XUINT (value
);
1493 else if (SYMBOLP (content
))
1494 CCL_CALL_FOR_MAP_INSTRUCTION (content
, fin_ic
);
1504 case CCL_MapMultiple
:
1506 Lisp_Object map
, content
, attrib
, value
;
1507 int point
, size
, map_vector_size
;
1508 int map_set_rest_length
, fin_ic
;
1509 int current_ic
= this_ic
;
1511 /* inhibit recursive call on MapMultiple. */
1512 if (stack_idx_of_map_multiple
> 0)
1514 if (stack_idx_of_map_multiple
<= stack_idx
)
1516 stack_idx_of_map_multiple
= 0;
1517 mapping_stack_pointer
= mapping_stack
;
1522 mapping_stack_pointer
= mapping_stack
;
1523 stack_idx_of_map_multiple
= 0;
1525 map_set_rest_length
=
1526 XINT (ccl_prog
[ic
++]); /* number of maps and separators. */
1527 fin_ic
= ic
+ map_set_rest_length
;
1530 if ((map_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1534 map_set_rest_length
-= i
;
1540 mapping_stack_pointer
= mapping_stack
;
1544 if (mapping_stack_pointer
<= (mapping_stack
+ 1))
1546 /* Set up initial state. */
1547 mapping_stack_pointer
= mapping_stack
;
1548 PUSH_MAPPING_STACK (0, op
);
1553 /* Recover after calling other ccl program. */
1556 POP_MAPPING_STACK (map_set_rest_length
, orig_op
);
1557 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1561 /* Regard it as Qnil. */
1565 map_set_rest_length
--;
1568 /* Regard it as Qt. */
1572 map_set_rest_length
--;
1575 /* Regard it as Qlambda. */
1577 i
+= map_set_rest_length
;
1578 ic
+= map_set_rest_length
;
1579 map_set_rest_length
= 0;
1582 /* Regard it as normal mapping. */
1583 i
+= map_set_rest_length
;
1584 ic
+= map_set_rest_length
;
1585 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1589 map_vector_size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1592 for (;map_set_rest_length
> 0;i
++, ic
++, map_set_rest_length
--)
1594 point
= XINT(ccl_prog
[ic
]);
1597 /* +1 is for including separator. */
1599 if (mapping_stack_pointer
1600 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1602 PUSH_MAPPING_STACK (map_set_rest_length
- point
,
1604 map_set_rest_length
= point
;
1609 if (point
>= map_vector_size
) continue;
1610 map
= (XVECTOR (Vcode_conversion_map_vector
)
1613 /* Check map varidity. */
1614 if (!CONSP (map
)) continue;
1616 if (!VECTORP (map
)) continue;
1617 size
= XVECTOR (map
)->size
;
1618 if (size
<= 1) continue;
1620 content
= XVECTOR (map
)->contents
[0];
1623 [STARTPOINT VAL1 VAL2 ...] or
1624 [t ELEMENT STARTPOINT ENDPOINT] */
1625 if (NUMBERP (content
))
1627 point
= XUINT (content
);
1628 point
= op
- point
+ 1;
1629 if (!((point
>= 1) && (point
< size
))) continue;
1630 content
= XVECTOR (map
)->contents
[point
];
1632 else if (EQ (content
, Qt
))
1634 if (size
!= 4) continue;
1635 if ((op
>= XUINT (XVECTOR (map
)->contents
[2])) &&
1636 (op
< XUINT (XVECTOR (map
)->contents
[3])))
1637 content
= XVECTOR (map
)->contents
[1];
1648 if (NUMBERP (content
))
1650 op
= XINT (content
);
1651 i
+= map_set_rest_length
- 1;
1652 ic
+= map_set_rest_length
- 1;
1653 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1654 map_set_rest_length
++;
1656 else if (CONSP (content
))
1658 attrib
= XCAR (content
);
1659 value
= XCDR (content
);
1660 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1663 i
+= map_set_rest_length
- 1;
1664 ic
+= map_set_rest_length
- 1;
1665 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1666 map_set_rest_length
++;
1668 else if (EQ (content
, Qt
))
1672 else if (EQ (content
, Qlambda
))
1674 i
+= map_set_rest_length
;
1675 ic
+= map_set_rest_length
;
1678 else if (SYMBOLP (content
))
1680 if (mapping_stack_pointer
1681 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1683 PUSH_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1684 PUSH_MAPPING_STACK (map_set_rest_length
, op
);
1685 stack_idx_of_map_multiple
= stack_idx
+ 1;
1686 CCL_CALL_FOR_MAP_INSTRUCTION (content
, current_ic
);
1691 if (mapping_stack_pointer
<= (mapping_stack
+ 1))
1693 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1694 i
+= map_set_rest_length
;
1695 ic
+= map_set_rest_length
;
1696 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1706 Lisp_Object map
, attrib
, value
, content
;
1708 j
= XINT (ccl_prog
[ic
++]); /* map_id */
1710 if (j
>= XVECTOR (Vcode_conversion_map_vector
)->size
)
1715 map
= XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1727 size
= XVECTOR (map
)->size
;
1728 point
= XUINT (XVECTOR (map
)->contents
[0]);
1729 point
= op
- point
+ 1;
1732 (!((point
>= 1) && (point
< size
))))
1737 content
= XVECTOR (map
)->contents
[point
];
1740 else if (NUMBERP (content
))
1741 reg
[rrr
] = XINT (content
);
1742 else if (EQ (content
, Qt
));
1743 else if (CONSP (content
))
1745 attrib
= XCAR (content
);
1746 value
= XCDR (content
);
1747 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1749 reg
[rrr
] = XUINT(value
);
1752 else if (SYMBOLP (content
))
1753 CCL_CALL_FOR_MAP_INSTRUCTION (content
, ic
);
1771 /* The suppress_error member is set when e.g. a CCL-based coding
1772 system is used for terminal output. */
1773 if (!ccl
->suppress_error
&& destination
)
1775 /* We can insert an error message only if DESTINATION is
1776 specified and we still have a room to store the message
1784 switch (ccl
->status
)
1786 case CCL_STAT_INVALID_CMD
:
1787 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1788 code
& 0x1F, code
, this_ic
);
1791 int i
= ccl_backtrace_idx
- 1;
1794 msglen
= strlen (msg
);
1795 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1797 bcopy (msg
, dst
, msglen
);
1801 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1803 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1804 if (ccl_backtrace_table
[i
] == 0)
1806 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1807 msglen
= strlen (msg
);
1808 if (dst
+ msglen
> (dst_bytes
? dst_end
: src
))
1810 bcopy (msg
, dst
, msglen
);
1819 sprintf(msg
, "\nCCL: Quited.");
1823 sprintf(msg
, "\nCCL: Unknown error type (%d).", ccl
->status
);
1826 msglen
= strlen (msg
);
1827 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1829 bcopy (msg
, dst
, msglen
);
1833 if (ccl
->status
== CCL_STAT_INVALID_CMD
)
1835 #if 0 /* If the remaining bytes contain 0x80..0x9F, copying them
1836 results in an invalid multibyte sequence. */
1838 /* Copy the remaining source data. */
1839 int i
= src_end
- src
;
1840 if (dst_bytes
&& (dst_end
- dst
) < i
)
1842 bcopy (src
, dst
, i
);
1846 /* Signal that we've consumed everything. */
1854 ccl
->stack_idx
= stack_idx
;
1855 ccl
->prog
= ccl_prog
;
1856 ccl
->eight_bit_control
= (extra_bytes
> 0);
1858 *consumed
= src
- source
;
1859 return (dst
? dst
- destination
: 0);
1862 /* Resolve symbols in the specified CCL code (Lisp vector). This
1863 function converts symbols of code conversion maps and character
1864 translation tables embeded in the CCL code into their ID numbers.
1866 The return value is a vector (CCL itself or a new vector in which
1867 all symbols are resolved), Qt if resolving of some symbol failed,
1868 or nil if CCL contains invalid data. */
1871 resolve_symbol_ccl_program (ccl
)
1874 int i
, veclen
, unresolved
= 0;
1875 Lisp_Object result
, contents
, val
;
1878 veclen
= XVECTOR (result
)->size
;
1880 for (i
= 0; i
< veclen
; i
++)
1882 contents
= XVECTOR (result
)->contents
[i
];
1883 if (INTEGERP (contents
))
1885 else if (CONSP (contents
)
1886 && SYMBOLP (XCAR (contents
))
1887 && SYMBOLP (XCDR (contents
)))
1889 /* This is the new style for embedding symbols. The form is
1890 (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
1893 if (EQ (result
, ccl
))
1894 result
= Fcopy_sequence (ccl
);
1896 val
= Fget (XCAR (contents
), XCDR (contents
));
1898 XVECTOR (result
)->contents
[i
] = val
;
1903 else if (SYMBOLP (contents
))
1905 /* This is the old style for embedding symbols. This style
1906 may lead to a bug if, for instance, a translation table
1907 and a code conversion map have the same name. */
1908 if (EQ (result
, ccl
))
1909 result
= Fcopy_sequence (ccl
);
1911 val
= Fget (contents
, Qtranslation_table_id
);
1913 XVECTOR (result
)->contents
[i
] = val
;
1916 val
= Fget (contents
, Qcode_conversion_map_id
);
1918 XVECTOR (result
)->contents
[i
] = val
;
1921 val
= Fget (contents
, Qccl_program_idx
);
1923 XVECTOR (result
)->contents
[i
] = val
;
1933 return (unresolved
? Qt
: result
);
1936 /* Return the compiled code (vector) of CCL program CCL_PROG.
1937 CCL_PROG is a name (symbol) of the program or already compiled
1938 code. If necessary, resolve symbols in the compiled code to index
1939 numbers. If we failed to get the compiled code or to resolve
1940 symbols, return Qnil. */
1943 ccl_get_compiled_code (ccl_prog
)
1944 Lisp_Object ccl_prog
;
1946 Lisp_Object val
, slot
;
1948 if (VECTORP (ccl_prog
))
1950 val
= resolve_symbol_ccl_program (ccl_prog
);
1951 return (VECTORP (val
) ? val
: Qnil
);
1953 if (!SYMBOLP (ccl_prog
))
1956 val
= Fget (ccl_prog
, Qccl_program_idx
);
1958 || XINT (val
) >= XVECTOR (Vccl_program_table
)->size
)
1960 slot
= XVECTOR (Vccl_program_table
)->contents
[XINT (val
)];
1961 if (! VECTORP (slot
)
1962 || XVECTOR (slot
)->size
!= 3
1963 || ! VECTORP (XVECTOR (slot
)->contents
[1]))
1965 if (NILP (XVECTOR (slot
)->contents
[2]))
1967 val
= resolve_symbol_ccl_program (XVECTOR (slot
)->contents
[1]);
1968 if (! VECTORP (val
))
1970 XVECTOR (slot
)->contents
[1] = val
;
1971 XVECTOR (slot
)->contents
[2] = Qt
;
1973 return XVECTOR (slot
)->contents
[1];
1976 /* Setup fields of the structure pointed by CCL appropriately for the
1977 execution of CCL program CCL_PROG. CCL_PROG is the name (symbol)
1978 of the CCL program or the already compiled code (vector).
1979 Return 0 if we succeed this setup, else return -1.
1981 If CCL_PROG is nil, we just reset the structure pointed by CCL. */
1983 setup_ccl_program (ccl
, ccl_prog
)
1984 struct ccl_program
*ccl
;
1985 Lisp_Object ccl_prog
;
1989 if (! NILP (ccl_prog
))
1991 struct Lisp_Vector
*vp
;
1993 ccl_prog
= ccl_get_compiled_code (ccl_prog
);
1994 if (! VECTORP (ccl_prog
))
1996 vp
= XVECTOR (ccl_prog
);
1997 ccl
->size
= vp
->size
;
1998 ccl
->prog
= vp
->contents
;
1999 ccl
->eof_ic
= XINT (vp
->contents
[CCL_HEADER_EOF
]);
2000 ccl
->buf_magnification
= XINT (vp
->contents
[CCL_HEADER_BUF_MAG
]);
2002 ccl
->ic
= CCL_HEADER_MAIN
;
2003 for (i
= 0; i
< 8; i
++)
2005 ccl
->last_block
= 0;
2006 ccl
->private_state
= 0;
2009 ccl
->eol_type
= CODING_EOL_LF
;
2010 ccl
->suppress_error
= 0;
2016 DEFUN ("ccl-program-p", Fccl_program_p
, Sccl_program_p
, 1, 1, 0,
2017 doc
: /* Return t if OBJECT is a CCL program name or a compiled CCL program code.
2018 See the documentation of `define-ccl-program' for the detail of CCL program. */)
2024 if (VECTORP (object
))
2026 val
= resolve_symbol_ccl_program (object
);
2027 return (VECTORP (val
) ? Qt
: Qnil
);
2029 if (!SYMBOLP (object
))
2032 val
= Fget (object
, Qccl_program_idx
);
2033 return ((! NATNUMP (val
)
2034 || XINT (val
) >= XVECTOR (Vccl_program_table
)->size
)
2038 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
2039 doc
: /* Execute CCL-PROGRAM with registers initialized by REGISTERS.
2041 CCL-PROGRAM is a CCL program name (symbol)
2042 or compiled code generated by `ccl-compile' (for backward compatibility.
2043 In the latter case, the execution overhead is bigger than in the former).
2044 No I/O commands should appear in CCL-PROGRAM.
2046 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value
2047 for the Nth register.
2049 As side effect, each element of REGISTERS holds the value of
2050 the corresponding register after the execution.
2052 See the documentation of `define-ccl-program' for a definition of CCL
2055 Lisp_Object ccl_prog
, reg
;
2057 struct ccl_program ccl
;
2060 if (setup_ccl_program (&ccl
, ccl_prog
) < 0)
2061 error ("Invalid CCL program");
2064 if (XVECTOR (reg
)->size
!= 8)
2065 error ("Length of vector REGISTERS is not 8");
2067 for (i
= 0; i
< 8; i
++)
2068 ccl
.reg
[i
] = (INTEGERP (XVECTOR (reg
)->contents
[i
])
2069 ? XINT (XVECTOR (reg
)->contents
[i
])
2072 ccl_driver (&ccl
, (unsigned char *)0, (unsigned char *)0, 0, 0, (int *)0);
2074 if (ccl
.status
!= CCL_STAT_SUCCESS
)
2075 error ("Error in CCL program at %dth code", ccl
.ic
);
2077 for (i
= 0; i
< 8; i
++)
2078 XSETINT (XVECTOR (reg
)->contents
[i
], ccl
.reg
[i
]);
2082 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
2084 doc
: /* Execute CCL-PROGRAM with initial STATUS on STRING.
2086 CCL-PROGRAM is a symbol registered by register-ccl-program,
2087 or a compiled code generated by `ccl-compile' (for backward compatibility,
2088 in this case, the execution is slower).
2090 Read buffer is set to STRING, and write buffer is allocated automatically.
2092 STATUS is a vector of [R0 R1 ... R7 IC], where
2093 R0..R7 are initial values of corresponding registers,
2094 IC is the instruction counter specifying from where to start the program.
2095 If R0..R7 are nil, they are initialized to 0.
2096 If IC is nil, it is initialized to head of the CCL program.
2098 If optional 4th arg CONTINUE is non-nil, keep IC on read operation
2099 when read buffer is exausted, else, IC is always set to the end of
2100 CCL-PROGRAM on exit.
2102 It returns the contents of write buffer as a string,
2103 and as side effect, STATUS is updated.
2104 If the optional 5th arg UNIBYTE-P is non-nil, the returned string
2105 is a unibyte string. By default it is a multibyte string.
2107 See the documentation of `define-ccl-program' for the detail of CCL program. */)
2108 (ccl_prog
, status
, str
, contin
, unibyte_p
)
2109 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
2112 struct ccl_program ccl
;
2116 struct gcpro gcpro1
, gcpro2
;
2118 if (setup_ccl_program (&ccl
, ccl_prog
) < 0)
2119 error ("Invalid CCL program");
2121 CHECK_VECTOR (status
);
2122 if (XVECTOR (status
)->size
!= 9)
2123 error ("Length of vector STATUS is not 9");
2126 GCPRO2 (status
, str
);
2128 for (i
= 0; i
< 8; i
++)
2130 if (NILP (XVECTOR (status
)->contents
[i
]))
2131 XSETINT (XVECTOR (status
)->contents
[i
], 0);
2132 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
2133 ccl
.reg
[i
] = XINT (XVECTOR (status
)->contents
[i
]);
2135 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
2137 i
= XFASTINT (XVECTOR (status
)->contents
[8]);
2138 if (ccl
.ic
< i
&& i
< ccl
.size
)
2141 outbufsize
= STRING_BYTES (XSTRING (str
)) * ccl
.buf_magnification
+ 256;
2142 outbuf
= (char *) xmalloc (outbufsize
);
2143 ccl
.last_block
= NILP (contin
);
2144 ccl
.multibyte
= STRING_MULTIBYTE (str
);
2145 produced
= ccl_driver (&ccl
, XSTRING (str
)->data
, outbuf
,
2146 STRING_BYTES (XSTRING (str
)), outbufsize
, (int *) 0);
2147 for (i
= 0; i
< 8; i
++)
2148 XSET (XVECTOR (status
)->contents
[i
], Lisp_Int
, ccl
.reg
[i
]);
2149 XSETINT (XVECTOR (status
)->contents
[8], ccl
.ic
);
2152 if (NILP (unibyte_p
))
2156 produced
= str_as_multibyte (outbuf
, outbufsize
, produced
, &nchars
);
2157 val
= make_multibyte_string (outbuf
, nchars
, produced
);
2160 val
= make_unibyte_string (outbuf
, produced
);
2163 if (ccl
.status
== CCL_STAT_SUSPEND_BY_DST
)
2164 error ("Output buffer for the CCL programs overflow");
2165 if (ccl
.status
!= CCL_STAT_SUCCESS
2166 && ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
)
2167 error ("Error in CCL program at %dth code", ccl
.ic
);
2172 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
2174 doc
: /* Register CCL program CCL_PROG as NAME in `ccl-program-table'.
2175 CCL_PROG should be a compiled CCL program (vector), or nil.
2176 If it is nil, just reserve NAME as a CCL program name.
2177 Return index number of the registered CCL program. */)
2179 Lisp_Object name
, ccl_prog
;
2181 int len
= XVECTOR (Vccl_program_table
)->size
;
2183 Lisp_Object resolved
;
2185 CHECK_SYMBOL (name
);
2187 if (!NILP (ccl_prog
))
2189 CHECK_VECTOR (ccl_prog
);
2190 resolved
= resolve_symbol_ccl_program (ccl_prog
);
2191 if (NILP (resolved
))
2192 error ("Error in CCL program");
2193 if (VECTORP (resolved
))
2195 ccl_prog
= resolved
;
2202 for (idx
= 0; idx
< len
; idx
++)
2206 slot
= XVECTOR (Vccl_program_table
)->contents
[idx
];
2207 if (!VECTORP (slot
))
2208 /* This is the first unsed slot. Register NAME here. */
2211 if (EQ (name
, XVECTOR (slot
)->contents
[0]))
2213 /* Update this slot. */
2214 XVECTOR (slot
)->contents
[1] = ccl_prog
;
2215 XVECTOR (slot
)->contents
[2] = resolved
;
2216 return make_number (idx
);
2222 /* Extend the table. */
2223 Lisp_Object new_table
;
2226 new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
2227 for (j
= 0; j
< len
; j
++)
2228 XVECTOR (new_table
)->contents
[j
]
2229 = XVECTOR (Vccl_program_table
)->contents
[j
];
2230 Vccl_program_table
= new_table
;
2236 elt
= Fmake_vector (make_number (3), Qnil
);
2237 XVECTOR (elt
)->contents
[0] = name
;
2238 XVECTOR (elt
)->contents
[1] = ccl_prog
;
2239 XVECTOR (elt
)->contents
[2] = resolved
;
2240 XVECTOR (Vccl_program_table
)->contents
[idx
] = elt
;
2243 Fput (name
, Qccl_program_idx
, make_number (idx
));
2244 return make_number (idx
);
2247 /* Register code conversion map.
2248 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
2249 The first element is the start code point.
2250 The other elements are mapped numbers.
2251 Symbol t means to map to an original number before mapping.
2252 Symbol nil means that the corresponding element is empty.
2253 Symbol lambda means to terminate mapping here.
2256 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map
,
2257 Sregister_code_conversion_map
,
2259 doc
: /* Register SYMBOL as code conversion map MAP.
2260 Return index number of the registered map. */)
2262 Lisp_Object symbol
, map
;
2264 int len
= XVECTOR (Vcode_conversion_map_vector
)->size
;
2268 CHECK_SYMBOL (symbol
);
2271 for (i
= 0; i
< len
; i
++)
2273 Lisp_Object slot
= XVECTOR (Vcode_conversion_map_vector
)->contents
[i
];
2278 if (EQ (symbol
, XCAR (slot
)))
2280 index
= make_number (i
);
2281 XSETCDR (slot
, map
);
2282 Fput (symbol
, Qcode_conversion_map
, map
);
2283 Fput (symbol
, Qcode_conversion_map_id
, index
);
2290 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
2293 for (j
= 0; j
< len
; j
++)
2294 XVECTOR (new_vector
)->contents
[j
]
2295 = XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
2296 Vcode_conversion_map_vector
= new_vector
;
2299 index
= make_number (i
);
2300 Fput (symbol
, Qcode_conversion_map
, map
);
2301 Fput (symbol
, Qcode_conversion_map_id
, index
);
2302 XVECTOR (Vcode_conversion_map_vector
)->contents
[i
] = Fcons (symbol
, map
);
2310 staticpro (&Vccl_program_table
);
2311 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
2313 Qccl_program
= intern ("ccl-program");
2314 staticpro (&Qccl_program
);
2316 Qccl_program_idx
= intern ("ccl-program-idx");
2317 staticpro (&Qccl_program_idx
);
2319 Qcode_conversion_map
= intern ("code-conversion-map");
2320 staticpro (&Qcode_conversion_map
);
2322 Qcode_conversion_map_id
= intern ("code-conversion-map-id");
2323 staticpro (&Qcode_conversion_map_id
);
2325 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector
,
2326 doc
: /* Vector of code conversion maps. */);
2327 Vcode_conversion_map_vector
= Fmake_vector (make_number (16), Qnil
);
2329 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
2330 doc
: /* Alist of fontname patterns vs corresponding CCL program.
2331 Each element looks like (REGEXP . CCL-CODE),
2332 where CCL-CODE is a compiled CCL program.
2333 When a font whose name matches REGEXP is used for displaying a character,
2334 CCL-CODE is executed to calculate the code point in the font
2335 from the charset number and position code(s) of the character which are set
2336 in CCL registers R0, R1, and R2 before the execution.
2337 The code point in the font is set in CCL registers R1 and R2
2338 when the execution terminated.
2339 If the font is single-byte font, the register R2 is not used. */);
2340 Vfont_ccl_encoder_alist
= Qnil
;
2342 defsubr (&Sccl_program_p
);
2343 defsubr (&Sccl_execute
);
2344 defsubr (&Sccl_execute_on_string
);
2345 defsubr (&Sregister_ccl_program
);
2346 defsubr (&Sregister_code_conversion_map
);