1 /* CCL (Code Conversion Language) interpreter.
2 Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
3 Licensed to the Free Software Foundation.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
39 #endif /* not emacs */
41 /* This contains all code conversion map available to CCL. */
42 Lisp_Object Vcode_conversion_map_vector
;
44 /* Alist of fontname patterns vs corresponding CCL program. */
45 Lisp_Object Vfont_ccl_encoder_alist
;
47 /* This symbol is a property which assocates with ccl program vector.
48 Ex: (get 'ccl-big5-encoder 'ccl-program) returns ccl program vector. */
49 Lisp_Object Qccl_program
;
51 /* These symbols are properties which associate with code conversion
52 map and their ID respectively. */
53 Lisp_Object Qcode_conversion_map
;
54 Lisp_Object Qcode_conversion_map_id
;
56 /* Symbols of ccl program have this property, a value of the property
57 is an index for Vccl_protram_table. */
58 Lisp_Object Qccl_program_idx
;
60 /* Table of registered CCL programs. Each element is a vector of
61 NAME, CCL_PROG, and RESOLVEDP where NAME (symbol) is the name of
62 the program, CCL_PROG (vector) is the compiled code of the program,
63 RESOLVEDP (t or nil) is the flag to tell if symbols in CCL_PROG is
64 already resolved to index numbers or not. */
65 Lisp_Object Vccl_program_table
;
67 /* CCL (Code Conversion Language) is a simple language which has
68 operations on one input buffer, one output buffer, and 7 registers.
69 The syntax of CCL is described in `ccl.el'. Emacs Lisp function
70 `ccl-compile' compiles a CCL program and produces a CCL code which
71 is a vector of integers. The structure of this vector is as
72 follows: The 1st element: buffer-magnification, a factor for the
73 size of output buffer compared with the size of input buffer. The
74 2nd element: address of CCL code to be executed when encountered
75 with end of input stream. The 3rd and the remaining elements: CCL
78 /* Header of CCL compiled code */
79 #define CCL_HEADER_BUF_MAG 0
80 #define CCL_HEADER_EOF 1
81 #define CCL_HEADER_MAIN 2
83 /* CCL code is a sequence of 28-bit non-negative integers (i.e. the
84 MSB is always 0), each contains CCL command and/or arguments in the
87 |----------------- integer (28-bit) ------------------|
88 |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
89 |--constant argument--|-register-|-register-|-command-|
90 ccccccccccccccccc RRR rrr XXXXX
92 |------- relative address -------|-register-|-command-|
93 cccccccccccccccccccc rrr XXXXX
95 |------------- constant or other args ----------------|
96 cccccccccccccccccccccccccccc
98 where, `cc...c' is a non-negative integer indicating constant value
99 (the left most `c' is always 0) or an absolute jump address, `RRR'
100 and `rrr' are CCL register number, `XXXXX' is one of the following
105 Each comment fields shows one or more lines for command syntax and
106 the following lines for semantics of the command. In semantics, IC
107 stands for Instruction Counter. */
109 #define CCL_SetRegister 0x00 /* Set register a register value:
110 1:00000000000000000RRRrrrXXXXX
111 ------------------------------
115 #define CCL_SetShortConst 0x01 /* Set register a short constant value:
116 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
117 ------------------------------
118 reg[rrr] = CCCCCCCCCCCCCCCCCCC;
121 #define CCL_SetConst 0x02 /* Set register a constant value:
122 1:00000000000000000000rrrXXXXX
124 ------------------------------
129 #define CCL_SetArray 0x03 /* Set register an element of array:
130 1:CCCCCCCCCCCCCCCCCRRRrrrXXXXX
134 ------------------------------
135 if (0 <= reg[RRR] < CC..C)
136 reg[rrr] = ELEMENT[reg[RRR]];
140 #define CCL_Jump 0x04 /* Jump:
141 1:A--D--D--R--E--S--S-000XXXXX
142 ------------------------------
146 /* Note: If CC..C is greater than 0, the second code is omitted. */
148 #define CCL_JumpCond 0x05 /* Jump conditional:
149 1:A--D--D--R--E--S--S-rrrXXXXX
150 ------------------------------
156 #define CCL_WriteRegisterJump 0x06 /* Write register and jump:
157 1:A--D--D--R--E--S--S-rrrXXXXX
158 ------------------------------
163 #define CCL_WriteRegisterReadJump 0x07 /* Write register, read, and jump:
164 1:A--D--D--R--E--S--S-rrrXXXXX
165 2:A--D--D--R--E--S--S-rrrYYYYY
166 -----------------------------
172 /* Note: If read is suspended, the resumed execution starts from the
173 second code (YYYYY == CCL_ReadJump). */
175 #define CCL_WriteConstJump 0x08 /* Write constant and jump:
176 1:A--D--D--R--E--S--S-000XXXXX
178 ------------------------------
183 #define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump:
184 1:A--D--D--R--E--S--S-rrrXXXXX
186 3:A--D--D--R--E--S--S-rrrYYYYY
187 -----------------------------
193 /* Note: If read is suspended, the resumed execution starts from the
194 second code (YYYYY == CCL_ReadJump). */
196 #define CCL_WriteStringJump 0x0A /* Write string and jump:
197 1:A--D--D--R--E--S--S-000XXXXX
199 3:0000STRIN[0]STRIN[1]STRIN[2]
201 ------------------------------
202 write_string (STRING, LENGTH);
206 #define CCL_WriteArrayReadJump 0x0B /* Write an array element, read, and jump:
207 1:A--D--D--R--E--S--S-rrrXXXXX
212 N:A--D--D--R--E--S--S-rrrYYYYY
213 ------------------------------
214 if (0 <= reg[rrr] < LENGTH)
215 write (ELEMENT[reg[rrr]]);
216 IC += LENGTH + 2; (... pointing at N+1)
220 /* Note: If read is suspended, the resumed execution starts from the
221 Nth code (YYYYY == CCL_ReadJump). */
223 #define CCL_ReadJump 0x0C /* Read and jump:
224 1:A--D--D--R--E--S--S-rrrYYYYY
225 -----------------------------
230 #define CCL_Branch 0x0D /* Jump by branch table:
231 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
232 2:A--D--D--R--E-S-S[0]000XXXXX
233 3:A--D--D--R--E-S-S[1]000XXXXX
235 ------------------------------
236 if (0 <= reg[rrr] < CC..C)
237 IC += ADDRESS[reg[rrr]];
239 IC += ADDRESS[CC..C];
242 #define CCL_ReadRegister 0x0E /* Read bytes into registers:
243 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
244 2:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
246 ------------------------------
251 #define CCL_WriteExprConst 0x0F /* write result of expression:
252 1:00000OPERATION000RRR000XXXXX
254 ------------------------------
255 write (reg[RRR] OPERATION CONSTANT);
259 /* Note: If the Nth read is suspended, the resumed execution starts
260 from the Nth code. */
262 #define CCL_ReadBranch 0x10 /* Read one byte into a register,
263 and jump by branch table:
264 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
265 2:A--D--D--R--E-S-S[0]000XXXXX
266 3:A--D--D--R--E-S-S[1]000XXXXX
268 ------------------------------
270 if (0 <= reg[rrr] < CC..C)
271 IC += ADDRESS[reg[rrr]];
273 IC += ADDRESS[CC..C];
276 #define CCL_WriteRegister 0x11 /* Write registers:
277 1:CCCCCCCCCCCCCCCCCCCrrrXXXXX
278 2:CCCCCCCCCCCCCCCCCCCrrrXXXXX
280 ------------------------------
286 /* Note: If the Nth write is suspended, the resumed execution
287 starts from the Nth code. */
289 #define CCL_WriteExprRegister 0x12 /* Write result of expression
290 1:00000OPERATIONRrrRRR000XXXXX
291 ------------------------------
292 write (reg[RRR] OPERATION reg[Rrr]);
295 #define CCL_Call 0x13 /* Call the CCL program whose ID is
297 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX
298 [2:00000000cccccccccccccccccccc]
299 ------------------------------
307 #define CCL_WriteConstString 0x14 /* Write a constant or a string:
308 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
309 [2:0000STRIN[0]STRIN[1]STRIN[2]]
311 -----------------------------
315 write_string (STRING, CC..C);
316 IC += (CC..C + 2) / 3;
319 #define CCL_WriteArray 0x15 /* Write an element of array:
320 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
324 ------------------------------
325 if (0 <= reg[rrr] < CC..C)
326 write (ELEMENT[reg[rrr]]);
330 #define CCL_End 0x16 /* Terminate:
331 1:00000000000000000000000XXXXX
332 ------------------------------
336 /* The following two codes execute an assignment arithmetic/logical
337 operation. The form of the operation is like REG OP= OPERAND. */
339 #define CCL_ExprSelfConst 0x17 /* REG OP= constant:
340 1:00000OPERATION000000rrrXXXXX
342 ------------------------------
343 reg[rrr] OPERATION= CONSTANT;
346 #define CCL_ExprSelfReg 0x18 /* REG1 OP= REG2:
347 1:00000OPERATION000RRRrrrXXXXX
348 ------------------------------
349 reg[rrr] OPERATION= reg[RRR];
352 /* The following codes execute an arithmetic/logical operation. The
353 form of the operation is like REG_X = REG_Y OP OPERAND2. */
355 #define CCL_SetExprConst 0x19 /* REG_X = REG_Y OP constant:
356 1:00000OPERATION000RRRrrrXXXXX
358 ------------------------------
359 reg[rrr] = reg[RRR] OPERATION CONSTANT;
363 #define CCL_SetExprReg 0x1A /* REG1 = REG2 OP REG3:
364 1:00000OPERATIONRrrRRRrrrXXXXX
365 ------------------------------
366 reg[rrr] = reg[RRR] OPERATION reg[Rrr];
369 #define CCL_JumpCondExprConst 0x1B /* Jump conditional according to
370 an operation on constant:
371 1:A--D--D--R--E--S--S-rrrXXXXX
374 -----------------------------
375 reg[7] = reg[rrr] OPERATION CONSTANT;
382 #define CCL_JumpCondExprReg 0x1C /* Jump conditional according to
383 an operation on register:
384 1:A--D--D--R--E--S--S-rrrXXXXX
387 -----------------------------
388 reg[7] = reg[rrr] OPERATION reg[RRR];
395 #define CCL_ReadJumpCondExprConst 0x1D /* Read and jump conditional according
396 to an operation on constant:
397 1:A--D--D--R--E--S--S-rrrXXXXX
400 -----------------------------
402 reg[7] = reg[rrr] OPERATION CONSTANT;
409 #define CCL_ReadJumpCondExprReg 0x1E /* Read and jump conditional according
410 to an operation on register:
411 1:A--D--D--R--E--S--S-rrrXXXXX
414 -----------------------------
416 reg[7] = reg[rrr] OPERATION reg[RRR];
423 #define CCL_Extention 0x1F /* Extended CCL code
424 1:ExtendedCOMMNDRrrRRRrrrXXXXX
427 ------------------------------
428 extended_command (rrr,RRR,Rrr,ARGS)
432 Here after, Extended CCL Instructions.
433 Bit length of extended command is 14.
434 Therefore, the instruction code range is 0..16384(0x3fff).
437 /* Read a multibyte characeter.
438 A code point is stored into reg[rrr]. A charset ID is stored into
441 #define CCL_ReadMultibyteChar2 0x00 /* Read Multibyte Character
442 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
444 /* Write a multibyte character.
445 Write a character whose code point is reg[rrr] and the charset ID
448 #define CCL_WriteMultibyteChar2 0x01 /* Write Multibyte Character
449 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
451 /* Translate a character whose code point is reg[rrr] and the charset
452 ID is reg[RRR] by a translation table whose ID is reg[Rrr].
454 A translated character is set in reg[rrr] (code point) and reg[RRR]
457 #define CCL_TranslateCharacter 0x02 /* Translate a multibyte character
458 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
460 /* Translate a character whose code point is reg[rrr] and the charset
461 ID is reg[RRR] by a translation table whose ID is ARGUMENT.
463 A translated character is set in reg[rrr] (code point) and reg[RRR]
466 #define CCL_TranslateCharacterConstTbl 0x03 /* Translate a multibyte character
467 1:ExtendedCOMMNDRrrRRRrrrXXXXX
468 2:ARGUMENT(Translation Table ID)
471 /* Iterate looking up MAPs for reg[rrr] starting from the Nth (N =
472 reg[RRR]) MAP until some value is found.
474 Each MAP is a Lisp vector whose element is number, nil, t, or
476 If the element is nil, ignore the map and proceed to the next map.
477 If the element is t or lambda, finish without changing reg[rrr].
478 If the element is a number, set reg[rrr] to the number and finish.
480 Detail of the map structure is descibed in the comment for
481 CCL_MapMultiple below. */
483 #define CCL_IterateMultipleMap 0x10 /* Iterate multiple maps
484 1:ExtendedCOMMNDXXXRRRrrrXXXXX
491 /* Map the code in reg[rrr] by MAPs starting from the Nth (N =
494 MAPs are supplied in the succeeding CCL codes as follows:
496 When CCL program gives this nested structure of map to this command:
499 (MAP-ID121 MAP-ID122 MAP-ID123)
502 (MAP-ID211 (MAP-ID2111) MAP-ID212)
504 the compiled CCL codes has this sequence:
505 CCL_MapMultiple (CCL code of this command)
506 16 (total number of MAPs and SEPARATORs)
524 A value of each SEPARATOR follows this rule:
525 MAP-SET := SEPARATOR [(MAP-ID | MAP-SET)]+
526 SEPARATOR := -(number of MAP-IDs and SEPARATORs in the MAP-SET)
528 (*)....Nest level of MAP-SET must not be over than MAX_MAP_SET_LEVEL.
530 When some map fails to map (i.e. it doesn't have a value for
531 reg[rrr]), the mapping is treated as identity.
533 The mapping is iterated for all maps in each map set (set of maps
534 separated by SEPARATOR) except in the case that lambda is
535 encountered. More precisely, the mapping proceeds as below:
537 At first, VAL0 is set to reg[rrr], and it is translated by the
538 first map to VAL1. Then, VAL1 is translated by the next map to
539 VAL2. This mapping is iterated until the last map is used. The
540 result of the mapping is the last value of VAL?.
542 But, when VALm is mapped to VALn and VALn is not a number, the
543 mapping proceed as below:
545 If VALn is nil, the lastest map is ignored and the mapping of VALm
546 proceed to the next map.
548 In VALn is t, VALm is reverted to reg[rrr] and the mapping of VALm
549 proceed to the next map.
551 If VALn is lambda, the whole mapping process terminates, and VALm
552 is the result of this mapping.
554 Each map is a Lisp vector of the following format (a) or (b):
555 (a)......[STARTPOINT VAL1 VAL2 ...]
556 (b)......[t VAL STARTPOINT ENDPOINT],
558 STARTPOINT is an offset to be used for indexing a map,
559 ENDPOINT is a maximum index number of a map,
560 VAL and VALn is a number, nil, t, or lambda.
562 Valid index range of a map of type (a) is:
563 STARTPOINT <= index < STARTPOINT + map_size - 1
564 Valid index range of a map of type (b) is:
565 STARTPOINT <= index < ENDPOINT */
567 #define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
568 1:ExtendedCOMMNDXXXRRRrrrXXXXX
580 #define MAX_MAP_SET_LEVEL 20
588 static tr_stack mapping_stack
[MAX_MAP_SET_LEVEL
];
589 static tr_stack
*mapping_stack_pointer
;
591 #define PUSH_MAPPING_STACK(restlen, orig) \
593 mapping_stack_pointer->rest_length = (restlen); \
594 mapping_stack_pointer->orig_val = (orig); \
595 mapping_stack_pointer++; \
598 #define POP_MAPPING_STACK(restlen, orig) \
600 mapping_stack_pointer--; \
601 (restlen) = mapping_stack_pointer->rest_length; \
602 (orig) = mapping_stack_pointer->orig_val; \
605 #define CCL_MapSingle 0x12 /* Map by single code conversion map
606 1:ExtendedCOMMNDXXXRRRrrrXXXXX
608 ------------------------------
609 Map reg[rrr] by MAP-ID.
610 If some valid mapping is found,
611 set reg[rrr] to the result,
616 /* CCL arithmetic/logical operators. */
617 #define CCL_PLUS 0x00 /* X = Y + Z */
618 #define CCL_MINUS 0x01 /* X = Y - Z */
619 #define CCL_MUL 0x02 /* X = Y * Z */
620 #define CCL_DIV 0x03 /* X = Y / Z */
621 #define CCL_MOD 0x04 /* X = Y % Z */
622 #define CCL_AND 0x05 /* X = Y & Z */
623 #define CCL_OR 0x06 /* X = Y | Z */
624 #define CCL_XOR 0x07 /* X = Y ^ Z */
625 #define CCL_LSH 0x08 /* X = Y << Z */
626 #define CCL_RSH 0x09 /* X = Y >> Z */
627 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
628 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
629 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
630 #define CCL_LS 0x10 /* X = (X < Y) */
631 #define CCL_GT 0x11 /* X = (X > Y) */
632 #define CCL_EQ 0x12 /* X = (X == Y) */
633 #define CCL_LE 0x13 /* X = (X <= Y) */
634 #define CCL_GE 0x14 /* X = (X >= Y) */
635 #define CCL_NE 0x15 /* X = (X != Y) */
637 #define CCL_DECODE_SJIS 0x16 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
638 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
639 #define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z))
640 r[7] = LOWER_BYTE (SJIS (Y, Z) */
642 /* Terminate CCL program successfully. */
643 #define CCL_SUCCESS \
645 ccl->status = CCL_STAT_SUCCESS; \
649 /* Suspend CCL program because of reading from empty input buffer or
650 writing to full output buffer. When this program is resumed, the
651 same I/O command is executed. */
652 #define CCL_SUSPEND(stat) \
655 ccl->status = stat; \
659 /* Terminate CCL program because of invalid command. Should not occur
660 in the normal case. */
661 #define CCL_INVALID_CMD \
663 ccl->status = CCL_STAT_INVALID_CMD; \
664 goto ccl_error_handler; \
667 /* Encode one character CH to multibyte form and write to the current
668 output buffer. If CH is less than 256, CH is written as is. */
669 #define CCL_WRITE_CHAR(ch) \
675 unsigned char str[MAX_MULTIBYTE_LENGTH], *p = str; \
676 int len = CHAR_STRING (ch, str); \
677 if (dst + len <= (dst_bytes ? dst_end : src)) \
679 while (len--) *dst++ = *p++; \
682 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
686 /* Write a string at ccl_prog[IC] of length LEN to the current output
688 #define CCL_WRITE_STRING(len) \
692 else if (dst + len <= (dst_bytes ? dst_end : src)) \
693 for (i = 0; i < len; i++) \
694 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
695 >> ((2 - (i % 3)) * 8)) & 0xFF; \
697 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
700 /* Read one byte from the current input buffer into Rth register. */
701 #define CCL_READ_CHAR(r) \
705 else if (src < src_end) \
707 else if (ccl->last_block) \
713 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
717 /* Set C to the character code made from CHARSET and CODE. This is
718 like MAKE_CHAR but check the validity of CHARSET and CODE. If they
719 are not valid, set C to (CODE & 0xFF) because that is usually the
720 case that CCL_ReadMultibyteChar2 read an invalid code and it set
721 CODE to that invalid byte. */
723 #define CCL_MAKE_CHAR(charset, code, c) \
725 if (charset == CHARSET_ASCII) \
727 else if (CHARSET_DEFINED_P (charset) \
728 && (code & 0x7F) >= 32 \
729 && (code < 256 || ((code >> 7) & 0x7F) >= 32)) \
731 int c1 = code & 0x7F, c2 = 0; \
734 c2 = c1, c1 = (code >> 7) & 0x7F; \
735 c = MAKE_NON_ASCII_CHAR (charset, c1, c2); \
742 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
743 text goes to a place pointed by DESTINATION, the length of which
744 should not exceed DST_BYTES. The bytes actually processed is
745 returned as *CONSUMED. The return value is the length of the
746 resulting text. As a side effect, the contents of CCL registers
747 are updated. If SOURCE or DESTINATION is NULL, only operations on
748 registers are permitted. */
751 #define CCL_DEBUG_BACKTRACE_LEN 256
752 int ccl_backtrace_table
[CCL_BACKTRACE_TABLE
];
753 int ccl_backtrace_idx
;
756 struct ccl_prog_stack
758 Lisp_Object
*ccl_prog
; /* Pointer to an array of CCL code. */
759 int ic
; /* Instruction Counter. */
762 /* For the moment, we only support depth 256 of stack. */
763 static struct ccl_prog_stack ccl_prog_stack_struct
[256];
766 ccl_driver (ccl
, source
, destination
, src_bytes
, dst_bytes
, consumed
)
767 struct ccl_program
*ccl
;
768 unsigned char *source
, *destination
;
769 int src_bytes
, dst_bytes
;
772 register int *reg
= ccl
->reg
;
773 register int ic
= ccl
->ic
;
774 register int code
, field1
, field2
;
775 register Lisp_Object
*ccl_prog
= ccl
->prog
;
776 unsigned char *src
= source
, *src_end
= src
+ src_bytes
;
777 unsigned char *dst
= destination
, *dst_end
= dst
+ dst_bytes
;
780 int stack_idx
= ccl
->stack_idx
;
781 /* Instruction counter of the current CCL code. */
784 if (ic
>= ccl
->eof_ic
)
785 ic
= CCL_HEADER_MAIN
;
787 if (ccl
->buf_magnification
==0) /* We can't produce any bytes. */
791 ccl_backtrace_idx
= 0;
798 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
799 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
800 ccl_backtrace_idx
= 0;
801 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
804 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
806 /* We can't just signal Qquit, instead break the loop as if
807 the whole data is processed. Don't reset Vquit_flag, it
808 must be handled later at a safer place. */
810 src
= source
+ src_bytes
;
811 ccl
->status
= CCL_STAT_QUIT
;
816 code
= XINT (ccl_prog
[ic
]); ic
++;
818 field2
= (code
& 0xFF) >> 5;
821 #define RRR (field1 & 7)
822 #define Rrr ((field1 >> 3) & 7)
824 #define EXCMD (field1 >> 6)
828 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
832 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
836 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
837 reg
[rrr
] = XINT (ccl_prog
[ic
]);
841 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
844 if ((unsigned int) i
< j
)
845 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
849 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
853 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
858 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
864 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
868 CCL_READ_CHAR (reg
[rrr
]);
872 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
873 i
= XINT (ccl_prog
[ic
]);
878 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
879 i
= XINT (ccl_prog
[ic
]);
882 CCL_READ_CHAR (reg
[rrr
]);
886 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
887 j
= XINT (ccl_prog
[ic
]);
889 CCL_WRITE_STRING (j
);
893 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
895 j
= XINT (ccl_prog
[ic
]);
896 if ((unsigned int) i
< j
)
898 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
902 CCL_READ_CHAR (reg
[rrr
]);
903 ic
+= ADDR
- (j
+ 2);
906 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
907 CCL_READ_CHAR (reg
[rrr
]);
911 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
912 CCL_READ_CHAR (reg
[rrr
]);
913 /* fall through ... */
914 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
915 if ((unsigned int) reg
[rrr
] < field1
)
916 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
918 ic
+= XINT (ccl_prog
[ic
+ field1
]);
921 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
924 CCL_READ_CHAR (reg
[rrr
]);
926 code
= XINT (ccl_prog
[ic
]); ic
++;
928 field2
= (code
& 0xFF) >> 5;
932 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
935 j
= XINT (ccl_prog
[ic
]);
937 jump_address
= ic
+ 1;
940 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
946 code
= XINT (ccl_prog
[ic
]); ic
++;
948 field2
= (code
& 0xFF) >> 5;
952 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
960 case CCL_Call
: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
965 /* If FFF is nonzero, the CCL program ID is in the
969 prog_id
= XINT (ccl_prog
[ic
]);
977 || prog_id
>= XVECTOR (Vccl_program_table
)->size
978 || (slot
= XVECTOR (Vccl_program_table
)->contents
[prog_id
],
980 || !VECTORP (XVECTOR (slot
)->contents
[1]))
984 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
985 ic
= ccl_prog_stack_struct
[0].ic
;
990 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
991 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
993 ccl_prog
= XVECTOR (XVECTOR (slot
)->contents
[1])->contents
;
994 ic
= CCL_HEADER_MAIN
;
998 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1000 CCL_WRITE_CHAR (field1
);
1003 CCL_WRITE_STRING (field1
);
1004 ic
+= (field1
+ 2) / 3;
1008 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1010 if ((unsigned int) i
< field1
)
1012 j
= XINT (ccl_prog
[ic
+ i
]);
1018 case CCL_End
: /* 0000000000000000000000XXXXX */
1019 if (stack_idx
-- > 0)
1021 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
1022 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
1027 /* ccl->ic should points to this command code again to
1028 suppress further processing. */
1032 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
1033 i
= XINT (ccl_prog
[ic
]);
1038 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
1045 case CCL_PLUS
: reg
[rrr
] += i
; break;
1046 case CCL_MINUS
: reg
[rrr
] -= i
; break;
1047 case CCL_MUL
: reg
[rrr
] *= i
; break;
1048 case CCL_DIV
: reg
[rrr
] /= i
; break;
1049 case CCL_MOD
: reg
[rrr
] %= i
; break;
1050 case CCL_AND
: reg
[rrr
] &= i
; break;
1051 case CCL_OR
: reg
[rrr
] |= i
; break;
1052 case CCL_XOR
: reg
[rrr
] ^= i
; break;
1053 case CCL_LSH
: reg
[rrr
] <<= i
; break;
1054 case CCL_RSH
: reg
[rrr
] >>= i
; break;
1055 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
1056 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
1057 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
1058 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
1059 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
1060 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
1061 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
1062 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
1063 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
1064 default: CCL_INVALID_CMD
;
1068 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1070 j
= XINT (ccl_prog
[ic
]);
1072 jump_address
= ++ic
;
1075 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1082 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1083 CCL_READ_CHAR (reg
[rrr
]);
1084 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1086 op
= XINT (ccl_prog
[ic
]);
1087 jump_address
= ic
++ + ADDR
;
1088 j
= XINT (ccl_prog
[ic
]);
1093 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1094 CCL_READ_CHAR (reg
[rrr
]);
1095 case CCL_JumpCondExprReg
:
1097 op
= XINT (ccl_prog
[ic
]);
1098 jump_address
= ic
++ + ADDR
;
1099 j
= reg
[XINT (ccl_prog
[ic
])];
1106 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1107 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1108 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1109 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1110 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1111 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1112 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1113 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1114 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1115 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1116 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1117 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1118 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1119 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1120 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1121 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1122 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1123 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1124 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1125 case CCL_DECODE_SJIS
: DECODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1126 case CCL_ENCODE_SJIS
: ENCODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1127 default: CCL_INVALID_CMD
;
1130 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1143 case CCL_ReadMultibyteChar2
:
1151 goto ccl_read_multibyte_character_suspend
;
1159 reg
[RRR
] = CHARSET_ASCII
;
1161 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION1
)
1164 goto ccl_read_multibyte_character_suspend
;
1166 reg
[rrr
] = (*src
++ & 0x7F);
1168 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION2
)
1170 if ((src
+ 1) >= src_end
)
1171 goto ccl_read_multibyte_character_suspend
;
1173 i
= (*src
++ & 0x7F);
1174 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1177 else if ((i
== LEADING_CODE_PRIVATE_11
)
1178 || (i
== LEADING_CODE_PRIVATE_12
))
1180 if ((src
+ 1) >= src_end
)
1181 goto ccl_read_multibyte_character_suspend
;
1183 reg
[rrr
] = (*src
++ & 0x7F);
1185 else if ((i
== LEADING_CODE_PRIVATE_21
)
1186 || (i
== LEADING_CODE_PRIVATE_22
))
1188 if ((src
+ 2) >= src_end
)
1189 goto ccl_read_multibyte_character_suspend
;
1191 i
= (*src
++ & 0x7F);
1192 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1197 /* INVALID CODE. Return a single byte character. */
1198 reg
[RRR
] = CHARSET_ASCII
;
1205 ccl_read_multibyte_character_suspend
:
1207 if (ccl
->last_block
)
1213 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC
);
1217 case CCL_WriteMultibyteChar2
:
1218 i
= reg
[RRR
]; /* charset */
1219 if (i
== CHARSET_ASCII
)
1220 i
= reg
[rrr
] & 0xFF;
1221 else if (CHARSET_DIMENSION (i
) == 1)
1222 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1223 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1224 i
= ((i
- 0x8F) << 14) | reg
[rrr
];
1226 i
= ((i
- 0xE0) << 14) | reg
[rrr
];
1232 case CCL_TranslateCharacter
:
1233 CCL_MAKE_CHAR (reg
[RRR
], reg
[rrr
], i
);
1234 op
= translate_char (GET_TRANSLATION_TABLE (reg
[Rrr
]),
1236 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1243 case CCL_TranslateCharacterConstTbl
:
1244 op
= XINT (ccl_prog
[ic
]); /* table */
1246 CCL_MAKE_CHAR (reg
[RRR
], reg
[rrr
], i
);
1247 op
= translate_char (GET_TRANSLATION_TABLE (op
), i
, -1, 0, 0);
1248 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1255 case CCL_IterateMultipleMap
:
1257 Lisp_Object map
, content
, attrib
, value
;
1258 int point
, size
, fin_ic
;
1260 j
= XINT (ccl_prog
[ic
++]); /* number of maps. */
1263 if ((j
> reg
[RRR
]) && (j
>= 0))
1278 size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1279 point
= XINT (ccl_prog
[ic
++]);
1280 if (point
>= size
) continue;
1282 XVECTOR (Vcode_conversion_map_vector
)->contents
[point
];
1284 /* Check map varidity. */
1285 if (!CONSP (map
)) continue;
1287 if (!VECTORP (map
)) continue;
1288 size
= XVECTOR (map
)->size
;
1289 if (size
<= 1) continue;
1291 content
= XVECTOR (map
)->contents
[0];
1294 [STARTPOINT VAL1 VAL2 ...] or
1295 [t ELELMENT STARTPOINT ENDPOINT] */
1296 if (NUMBERP (content
))
1298 point
= XUINT (content
);
1299 point
= op
- point
+ 1;
1300 if (!((point
>= 1) && (point
< size
))) continue;
1301 content
= XVECTOR (map
)->contents
[point
];
1303 else if (EQ (content
, Qt
))
1305 if (size
!= 4) continue;
1306 if ((op
>= XUINT (XVECTOR (map
)->contents
[2]))
1307 && (op
< XUINT (XVECTOR (map
)->contents
[3])))
1308 content
= XVECTOR (map
)->contents
[1];
1317 else if (NUMBERP (content
))
1320 reg
[rrr
] = XINT(content
);
1323 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1328 else if (CONSP (content
))
1330 attrib
= XCAR (content
);
1331 value
= XCDR (content
);
1332 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1335 reg
[rrr
] = XUINT (value
);
1345 case CCL_MapMultiple
:
1347 Lisp_Object map
, content
, attrib
, value
;
1348 int point
, size
, map_vector_size
;
1349 int map_set_rest_length
, fin_ic
;
1351 map_set_rest_length
=
1352 XINT (ccl_prog
[ic
++]); /* number of maps and separators. */
1353 fin_ic
= ic
+ map_set_rest_length
;
1354 if ((map_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1358 map_set_rest_length
-= i
;
1366 mapping_stack_pointer
= mapping_stack
;
1368 PUSH_MAPPING_STACK (0, op
);
1370 map_vector_size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1371 for (;map_set_rest_length
> 0;i
++, map_set_rest_length
--)
1373 point
= XINT(ccl_prog
[ic
++]);
1377 if (mapping_stack_pointer
1378 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1382 PUSH_MAPPING_STACK (map_set_rest_length
- point
,
1384 map_set_rest_length
= point
+ 1;
1389 if (point
>= map_vector_size
) continue;
1390 map
= (XVECTOR (Vcode_conversion_map_vector
)
1393 /* Check map varidity. */
1394 if (!CONSP (map
)) continue;
1396 if (!VECTORP (map
)) continue;
1397 size
= XVECTOR (map
)->size
;
1398 if (size
<= 1) continue;
1400 content
= XVECTOR (map
)->contents
[0];
1403 [STARTPOINT VAL1 VAL2 ...] or
1404 [t ELEMENT STARTPOINT ENDPOINT] */
1405 if (NUMBERP (content
))
1407 point
= XUINT (content
);
1408 point
= op
- point
+ 1;
1409 if (!((point
>= 1) && (point
< size
))) continue;
1410 content
= XVECTOR (map
)->contents
[point
];
1412 else if (EQ (content
, Qt
))
1414 if (size
!= 4) continue;
1415 if ((op
>= XUINT (XVECTOR (map
)->contents
[2])) &&
1416 (op
< XUINT (XVECTOR (map
)->contents
[3])))
1417 content
= XVECTOR (map
)->contents
[1];
1426 else if (NUMBERP (content
))
1428 op
= XINT (content
);
1430 i
+= map_set_rest_length
;
1431 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1433 else if (CONSP (content
))
1435 attrib
= XCAR (content
);
1436 value
= XCDR (content
);
1437 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1441 i
+= map_set_rest_length
;
1442 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1444 else if (EQ (content
, Qt
))
1448 i
+= map_set_rest_length
;
1449 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1451 else if (EQ (content
, Qlambda
))
1465 Lisp_Object map
, attrib
, value
, content
;
1467 j
= XINT (ccl_prog
[ic
++]); /* map_id */
1469 if (j
>= XVECTOR (Vcode_conversion_map_vector
)->size
)
1474 map
= XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1486 size
= XVECTOR (map
)->size
;
1487 point
= XUINT (XVECTOR (map
)->contents
[0]);
1488 point
= op
- point
+ 1;
1491 (!((point
>= 1) && (point
< size
))))
1495 content
= XVECTOR (map
)->contents
[point
];
1498 else if (NUMBERP (content
))
1499 reg
[rrr
] = XINT (content
);
1500 else if (EQ (content
, Qt
))
1502 else if (CONSP (content
))
1504 attrib
= XCAR (content
);
1505 value
= XCDR (content
);
1506 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1508 reg
[rrr
] = XUINT(value
);
1530 /* We can insert an error message only if DESTINATION is
1531 specified and we still have a room to store the message
1539 switch (ccl
->status
)
1541 case CCL_STAT_INVALID_CMD
:
1542 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1543 code
& 0x1F, code
, this_ic
);
1546 int i
= ccl_backtrace_idx
- 1;
1549 msglen
= strlen (msg
);
1550 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1552 bcopy (msg
, dst
, msglen
);
1556 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1558 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1559 if (ccl_backtrace_table
[i
] == 0)
1561 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1562 msglen
= strlen (msg
);
1563 if (dst
+ msglen
> (dst_bytes
? dst_end
: src
))
1565 bcopy (msg
, dst
, msglen
);
1574 sprintf(msg
, "\nCCL: Quited.");
1578 sprintf(msg
, "\nCCL: Unknown error type (%d).", ccl
->status
);
1581 msglen
= strlen (msg
);
1582 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1584 bcopy (msg
, dst
, msglen
);
1591 ccl
->stack_idx
= stack_idx
;
1592 ccl
->prog
= ccl_prog
;
1593 if (consumed
) *consumed
= src
- source
;
1594 return (dst
? dst
- destination
: 0);
1597 /* Resolve symbols in the specified CCL code (Lisp vector). This
1598 function converts symbols of code conversion maps and character
1599 translation tables embeded in the CCL code into their ID numbers.
1601 The return value is a vector (CCL itself or a new vector in which
1602 all symbols are resolved), Qt if resolving of some symbol failed,
1603 or nil if CCL contains invalid data. */
1606 resolve_symbol_ccl_program (ccl
)
1609 int i
, veclen
, unresolved
= 0;
1610 Lisp_Object result
, contents
, val
;
1613 veclen
= XVECTOR (result
)->size
;
1615 for (i
= 0; i
< veclen
; i
++)
1617 contents
= XVECTOR (result
)->contents
[i
];
1618 if (INTEGERP (contents
))
1620 else if (CONSP (contents
)
1621 && SYMBOLP (XCAR (contents
))
1622 && SYMBOLP (XCDR (contents
)))
1624 /* This is the new style for embedding symbols. The form is
1625 (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
1628 if (EQ (result
, ccl
))
1629 result
= Fcopy_sequence (ccl
);
1631 val
= Fget (XCAR (contents
), XCDR (contents
));
1633 XVECTOR (result
)->contents
[i
] = val
;
1638 else if (SYMBOLP (contents
))
1640 /* This is the old style for embedding symbols. This style
1641 may lead to a bug if, for instance, a translation table
1642 and a code conversion map have the same name. */
1643 if (EQ (result
, ccl
))
1644 result
= Fcopy_sequence (ccl
);
1646 val
= Fget (contents
, Qtranslation_table_id
);
1648 XVECTOR (result
)->contents
[i
] = val
;
1651 val
= Fget (contents
, Qcode_conversion_map_id
);
1653 XVECTOR (result
)->contents
[i
] = val
;
1656 val
= Fget (contents
, Qccl_program_idx
);
1658 XVECTOR (result
)->contents
[i
] = val
;
1668 return (unresolved
? Qt
: result
);
1671 /* Return the compiled code (vector) of CCL program CCL_PROG.
1672 CCL_PROG is a name (symbol) of the program or already compiled
1673 code. If necessary, resolve symbols in the compiled code to index
1674 numbers. If we failed to get the compiled code or to resolve
1675 symbols, return Qnil. */
1678 ccl_get_compiled_code (ccl_prog
)
1679 Lisp_Object ccl_prog
;
1681 Lisp_Object val
, slot
;
1683 if (VECTORP (ccl_prog
))
1685 val
= resolve_symbol_ccl_program (ccl_prog
);
1686 return (VECTORP (val
) ? val
: Qnil
);
1688 if (!SYMBOLP (ccl_prog
))
1691 val
= Fget (ccl_prog
, Qccl_program_idx
);
1693 || XINT (val
) >= XVECTOR (Vccl_program_table
)->size
)
1695 slot
= XVECTOR (Vccl_program_table
)->contents
[XINT (val
)];
1696 if (! VECTORP (slot
)
1697 || XVECTOR (slot
)->size
!= 3
1698 || ! VECTORP (XVECTOR (slot
)->contents
[1]))
1700 if (NILP (XVECTOR (slot
)->contents
[2]))
1702 val
= resolve_symbol_ccl_program (XVECTOR (slot
)->contents
[1]);
1703 if (! VECTORP (val
))
1705 XVECTOR (slot
)->contents
[1] = val
;
1706 XVECTOR (slot
)->contents
[2] = Qt
;
1708 return XVECTOR (slot
)->contents
[1];
1711 /* Setup fields of the structure pointed by CCL appropriately for the
1712 execution of CCL program CCL_PROG. CCL_PROG is the name (symbol)
1713 of the CCL program or the already compiled code (vector).
1714 Return 0 if we succeed this setup, else return -1.
1716 If CCL_PROG is nil, we just reset the structure pointed by CCL. */
1718 setup_ccl_program (ccl
, ccl_prog
)
1719 struct ccl_program
*ccl
;
1720 Lisp_Object ccl_prog
;
1724 if (! NILP (ccl_prog
))
1726 struct Lisp_Vector
*vp
;
1728 ccl_prog
= ccl_get_compiled_code (ccl_prog
);
1729 if (! VECTORP (ccl_prog
))
1731 vp
= XVECTOR (ccl_prog
);
1732 ccl
->size
= vp
->size
;
1733 ccl
->prog
= vp
->contents
;
1734 ccl
->eof_ic
= XINT (vp
->contents
[CCL_HEADER_EOF
]);
1735 ccl
->buf_magnification
= XINT (vp
->contents
[CCL_HEADER_BUF_MAG
]);
1737 ccl
->ic
= CCL_HEADER_MAIN
;
1738 for (i
= 0; i
< 8; i
++)
1740 ccl
->last_block
= 0;
1741 ccl
->private_state
= 0;
1749 DEFUN ("ccl-program-p", Fccl_program_p
, Sccl_program_p
, 1, 1, 0,
1750 "Return t if OBJECT is a CCL program name or a compiled CCL program code.")
1756 if (VECTORP (object
))
1758 val
= resolve_symbol_ccl_program (object
);
1759 return (VECTORP (val
) ? Qt
: Qnil
);
1761 if (!SYMBOLP (object
))
1764 val
= Fget (object
, Qccl_program_idx
);
1765 return ((! NATNUMP (val
)
1766 || XINT (val
) >= XVECTOR (Vccl_program_table
)->size
)
1770 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
1771 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1773 CCL-PROGRAM is a CCL program name (symbol)\n\
1774 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1775 in this case, the overhead of the execution is bigger than the former case).\n\
1776 No I/O commands should appear in CCL-PROGRAM.\n\
1778 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1781 As side effect, each element of REGISTERS holds the value of\n\
1782 corresponding register after the execution.")
1784 Lisp_Object ccl_prog
, reg
;
1786 struct ccl_program ccl
;
1789 if (setup_ccl_program (&ccl
, ccl_prog
) < 0)
1790 error ("Invalid CCL program");
1792 CHECK_VECTOR (reg
, 1);
1793 if (XVECTOR (reg
)->size
!= 8)
1794 error ("Length of vector REGISTERS is not 9");
1796 for (i
= 0; i
< 8; i
++)
1797 ccl
.reg
[i
] = (INTEGERP (XVECTOR (reg
)->contents
[i
])
1798 ? XINT (XVECTOR (reg
)->contents
[i
])
1801 ccl_driver (&ccl
, (char *)0, (char *)0, 0, 0, (int *)0);
1803 if (ccl
.status
!= CCL_STAT_SUCCESS
)
1804 error ("Error in CCL program at %dth code", ccl
.ic
);
1806 for (i
= 0; i
< 8; i
++)
1807 XSETINT (XVECTOR (reg
)->contents
[i
], ccl
.reg
[i
]);
1811 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
1813 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
1815 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1816 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1817 in this case, the execution is slower).\n\
1819 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
1821 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
1822 R0..R7 are initial values of corresponding registers,\n\
1823 IC is the instruction counter specifying from where to start the program.\n\
1824 If R0..R7 are nil, they are initialized to 0.\n\
1825 If IC is nil, it is initialized to head of the CCL program.\n\
1827 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
1828 when read buffer is exausted, else, IC is always set to the end of\n\
1829 CCL-PROGRAM on exit.\n\
1831 It returns the contents of write buffer as a string,\n\
1832 and as side effect, STATUS is updated.\n\
1833 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
1834 is a unibyte string. By default it is a multibyte string.")
1835 (ccl_prog
, status
, str
, contin
, unibyte_p
)
1836 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
1839 struct ccl_program ccl
;
1843 struct gcpro gcpro1
, gcpro2
;
1845 if (setup_ccl_program (&ccl
, ccl_prog
) < 0)
1846 error ("Invalid CCL program");
1848 CHECK_VECTOR (status
, 1);
1849 if (XVECTOR (status
)->size
!= 9)
1850 error ("Length of vector STATUS is not 9");
1851 CHECK_STRING (str
, 2);
1853 GCPRO2 (status
, str
);
1855 for (i
= 0; i
< 8; i
++)
1857 if (NILP (XVECTOR (status
)->contents
[i
]))
1858 XSETINT (XVECTOR (status
)->contents
[i
], 0);
1859 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1860 ccl
.reg
[i
] = XINT (XVECTOR (status
)->contents
[i
]);
1862 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1864 i
= XFASTINT (XVECTOR (status
)->contents
[8]);
1865 if (ccl
.ic
< i
&& i
< ccl
.size
)
1868 outbufsize
= STRING_BYTES (XSTRING (str
)) * ccl
.buf_magnification
+ 256;
1869 outbuf
= (char *) xmalloc (outbufsize
);
1871 error ("Not enough memory");
1872 ccl
.last_block
= NILP (contin
);
1873 produced
= ccl_driver (&ccl
, XSTRING (str
)->data
, outbuf
,
1874 STRING_BYTES (XSTRING (str
)), outbufsize
, (int *)0);
1875 for (i
= 0; i
< 8; i
++)
1876 XSET (XVECTOR (status
)->contents
[i
], Lisp_Int
, ccl
.reg
[i
]);
1877 XSETINT (XVECTOR (status
)->contents
[8], ccl
.ic
);
1880 if (NILP (unibyte_p
))
1881 val
= make_string (outbuf
, produced
);
1883 val
= make_unibyte_string (outbuf
, produced
);
1886 if (ccl
.status
!= CCL_STAT_SUCCESS
1887 && ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
1888 && ccl
.status
!= CCL_STAT_SUSPEND_BY_DST
)
1889 error ("Error in CCL program at %dth code", ccl
.ic
);
1894 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
1896 "Register CCL program CCL_PROG as NAME in `ccl-program-table'.\n\
1897 CCL_PROG should be a compiled CCL program (vector), or nil.\n\
1898 If it is nil, just reserve NAME as a CCL program name.\n\
1899 Return index number of the registered CCL program.")
1901 Lisp_Object name
, ccl_prog
;
1903 int len
= XVECTOR (Vccl_program_table
)->size
;
1905 Lisp_Object resolved
;
1907 CHECK_SYMBOL (name
, 0);
1909 if (!NILP (ccl_prog
))
1911 CHECK_VECTOR (ccl_prog
, 1);
1912 resolved
= resolve_symbol_ccl_program (ccl_prog
);
1913 if (! NILP (resolved
))
1915 ccl_prog
= resolved
;
1920 for (idx
= 0; idx
< len
; idx
++)
1924 slot
= XVECTOR (Vccl_program_table
)->contents
[idx
];
1925 if (!VECTORP (slot
))
1926 /* This is the first unsed slot. Register NAME here. */
1929 if (EQ (name
, XVECTOR (slot
)->contents
[0]))
1931 /* Update this slot. */
1932 XVECTOR (slot
)->contents
[1] = ccl_prog
;
1933 XVECTOR (slot
)->contents
[2] = resolved
;
1934 return make_number (idx
);
1940 /* Extend the table. */
1941 Lisp_Object new_table
;
1944 new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
1945 for (j
= 0; j
< len
; j
++)
1946 XVECTOR (new_table
)->contents
[j
]
1947 = XVECTOR (Vccl_program_table
)->contents
[j
];
1948 Vccl_program_table
= new_table
;
1954 elt
= Fmake_vector (make_number (3), Qnil
);
1955 XVECTOR (elt
)->contents
[0] = name
;
1956 XVECTOR (elt
)->contents
[1] = ccl_prog
;
1957 XVECTOR (elt
)->contents
[2] = resolved
;
1958 XVECTOR (Vccl_program_table
)->contents
[idx
] = elt
;
1961 Fput (name
, Qccl_program_idx
, make_number (idx
));
1962 return make_number (idx
);
1965 /* Register code conversion map.
1966 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
1967 The first element is start code point.
1968 The rest elements are mapped numbers.
1969 Symbol t means to map to an original number before mapping.
1970 Symbol nil means that the corresponding element is empty.
1971 Symbol lambda menas to terminate mapping here.
1974 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map
,
1975 Sregister_code_conversion_map
,
1977 "Register SYMBOL as code conversion map MAP.\n\
1978 Return index number of the registered map.")
1980 Lisp_Object symbol
, map
;
1982 int len
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1986 CHECK_SYMBOL (symbol
, 0);
1987 CHECK_VECTOR (map
, 1);
1989 for (i
= 0; i
< len
; i
++)
1991 Lisp_Object slot
= XVECTOR (Vcode_conversion_map_vector
)->contents
[i
];
1996 if (EQ (symbol
, XCAR (slot
)))
1998 index
= make_number (i
);
2000 Fput (symbol
, Qcode_conversion_map
, map
);
2001 Fput (symbol
, Qcode_conversion_map_id
, index
);
2008 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
2011 for (j
= 0; j
< len
; j
++)
2012 XVECTOR (new_vector
)->contents
[j
]
2013 = XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
2014 Vcode_conversion_map_vector
= new_vector
;
2017 index
= make_number (i
);
2018 Fput (symbol
, Qcode_conversion_map
, map
);
2019 Fput (symbol
, Qcode_conversion_map_id
, index
);
2020 XVECTOR (Vcode_conversion_map_vector
)->contents
[i
] = Fcons (symbol
, map
);
2028 staticpro (&Vccl_program_table
);
2029 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
2031 Qccl_program
= intern ("ccl-program");
2032 staticpro (&Qccl_program
);
2034 Qccl_program_idx
= intern ("ccl-program-idx");
2035 staticpro (&Qccl_program_idx
);
2037 Qcode_conversion_map
= intern ("code-conversion-map");
2038 staticpro (&Qcode_conversion_map
);
2040 Qcode_conversion_map_id
= intern ("code-conversion-map-id");
2041 staticpro (&Qcode_conversion_map_id
);
2043 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector
,
2044 "Vector of code conversion maps.");
2045 Vcode_conversion_map_vector
= Fmake_vector (make_number (16), Qnil
);
2047 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
2048 "Alist of fontname patterns vs corresponding CCL program.\n\
2049 Each element looks like (REGEXP . CCL-CODE),\n\
2050 where CCL-CODE is a compiled CCL program.\n\
2051 When a font whose name matches REGEXP is used for displaying a character,\n\
2052 CCL-CODE is executed to calculate the code point in the font\n\
2053 from the charset number and position code(s) of the character which are set\n\
2054 in CCL registers R0, R1, and R2 before the execution.\n\
2055 The code point in the font is set in CCL registers R1 and R2\n\
2056 when the execution terminated.\n\
2057 If the font is single-byte font, the register R2 is not used.");
2058 Vfont_ccl_encoder_alist
= Qnil
;
2060 defsubr (&Sccl_program_p
);
2061 defsubr (&Sccl_execute
);
2062 defsubr (&Sccl_execute_on_string
);
2063 defsubr (&Sregister_ccl_program
);
2064 defsubr (&Sregister_code_conversion_map
);