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. */
41 #endif /* not emacs */
43 /* Where is stored translation tables for CCL program. */
44 Lisp_Object Vccl_translation_table_vector
;
46 /* Alist of fontname patterns vs corresponding CCL program. */
47 Lisp_Object Vfont_ccl_encoder_alist
;
49 /* This symbol is a property which assocates with ccl program vector.
50 Ex: (get 'ccl-big5-encoder 'ccl-program) returns ccl program vector. */
51 Lisp_Object Qccl_program
;
53 /* These symbols are properties which associate with ccl translation
54 tables and their ID respectively. */
55 Lisp_Object Qccl_translation_table
;
56 Lisp_Object Qccl_translation_table_id
;
58 /* Symbols of ccl program have this property, a value of the property
59 is an index for Vccl_protram_table. */
60 Lisp_Object Qccl_program_idx
;
62 /* These symbols are properties which associate with character
63 unification tables and their ID respectively. */
64 Lisp_Object Qunification_table
;
65 Lisp_Object Qunification_table_id
;
67 /* Vector of CCL program names vs corresponding program data. */
68 Lisp_Object Vccl_program_table
;
70 /* CCL (Code Conversion Language) is a simple language which has
71 operations on one input buffer, one output buffer, and 7 registers.
72 The syntax of CCL is described in `ccl.el'. Emacs Lisp function
73 `ccl-compile' compiles a CCL program and produces a CCL code which
74 is a vector of integers. The structure of this vector is as
75 follows: The 1st element: buffer-magnification, a factor for the
76 size of output buffer compared with the size of input buffer. The
77 2nd element: address of CCL code to be executed when encountered
78 with end of input stream. The 3rd and the remaining elements: CCL
81 /* Header of CCL compiled code */
82 #define CCL_HEADER_BUF_MAG 0
83 #define CCL_HEADER_EOF 1
84 #define CCL_HEADER_MAIN 2
86 /* CCL code is a sequence of 28-bit non-negative integers (i.e. the
87 MSB is always 0), each contains CCL command and/or arguments in the
90 |----------------- integer (28-bit) ------------------|
91 |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
92 |--constant argument--|-register-|-register-|-command-|
93 ccccccccccccccccc RRR rrr XXXXX
95 |------- relative address -------|-register-|-command-|
96 cccccccccccccccccccc rrr XXXXX
98 |------------- constant or other args ----------------|
99 cccccccccccccccccccccccccccc
101 where, `cc...c' is a non-negative integer indicating constant value
102 (the left most `c' is always 0) or an absolute jump address, `RRR'
103 and `rrr' are CCL register number, `XXXXX' is one of the following
108 Each comment fields shows one or more lines for command syntax and
109 the following lines for semantics of the command. In semantics, IC
110 stands for Instruction Counter. */
112 #define CCL_SetRegister 0x00 /* Set register a register value:
113 1:00000000000000000RRRrrrXXXXX
114 ------------------------------
118 #define CCL_SetShortConst 0x01 /* Set register a short constant value:
119 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
120 ------------------------------
121 reg[rrr] = CCCCCCCCCCCCCCCCCCC;
124 #define CCL_SetConst 0x02 /* Set register a constant value:
125 1:00000000000000000000rrrXXXXX
127 ------------------------------
132 #define CCL_SetArray 0x03 /* Set register an element of array:
133 1:CCCCCCCCCCCCCCCCCRRRrrrXXXXX
137 ------------------------------
138 if (0 <= reg[RRR] < CC..C)
139 reg[rrr] = ELEMENT[reg[RRR]];
143 #define CCL_Jump 0x04 /* Jump:
144 1:A--D--D--R--E--S--S-000XXXXX
145 ------------------------------
149 /* Note: If CC..C is greater than 0, the second code is omitted. */
151 #define CCL_JumpCond 0x05 /* Jump conditional:
152 1:A--D--D--R--E--S--S-rrrXXXXX
153 ------------------------------
159 #define CCL_WriteRegisterJump 0x06 /* Write register and jump:
160 1:A--D--D--R--E--S--S-rrrXXXXX
161 ------------------------------
166 #define CCL_WriteRegisterReadJump 0x07 /* Write register, read, and jump:
167 1:A--D--D--R--E--S--S-rrrXXXXX
168 2:A--D--D--R--E--S--S-rrrYYYYY
169 -----------------------------
175 /* Note: If read is suspended, the resumed execution starts from the
176 second code (YYYYY == CCL_ReadJump). */
178 #define CCL_WriteConstJump 0x08 /* Write constant and jump:
179 1:A--D--D--R--E--S--S-000XXXXX
181 ------------------------------
186 #define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump:
187 1:A--D--D--R--E--S--S-rrrXXXXX
189 3:A--D--D--R--E--S--S-rrrYYYYY
190 -----------------------------
196 /* Note: If read is suspended, the resumed execution starts from the
197 second code (YYYYY == CCL_ReadJump). */
199 #define CCL_WriteStringJump 0x0A /* Write string and jump:
200 1:A--D--D--R--E--S--S-000XXXXX
202 3:0000STRIN[0]STRIN[1]STRIN[2]
204 ------------------------------
205 write_string (STRING, LENGTH);
209 #define CCL_WriteArrayReadJump 0x0B /* Write an array element, read, and jump:
210 1:A--D--D--R--E--S--S-rrrXXXXX
215 N:A--D--D--R--E--S--S-rrrYYYYY
216 ------------------------------
217 if (0 <= reg[rrr] < LENGTH)
218 write (ELEMENT[reg[rrr]]);
219 IC += LENGTH + 2; (... pointing at N+1)
223 /* Note: If read is suspended, the resumed execution starts from the
224 Nth code (YYYYY == CCL_ReadJump). */
226 #define CCL_ReadJump 0x0C /* Read and jump:
227 1:A--D--D--R--E--S--S-rrrYYYYY
228 -----------------------------
233 #define CCL_Branch 0x0D /* Jump by branch table:
234 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
235 2:A--D--D--R--E-S-S[0]000XXXXX
236 3:A--D--D--R--E-S-S[1]000XXXXX
238 ------------------------------
239 if (0 <= reg[rrr] < CC..C)
240 IC += ADDRESS[reg[rrr]];
242 IC += ADDRESS[CC..C];
245 #define CCL_ReadRegister 0x0E /* Read bytes into registers:
246 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
247 2:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
249 ------------------------------
254 #define CCL_WriteExprConst 0x0F /* write result of expression:
255 1:00000OPERATION000RRR000XXXXX
257 ------------------------------
258 write (reg[RRR] OPERATION CONSTANT);
262 /* Note: If the Nth read is suspended, the resumed execution starts
263 from the Nth code. */
265 #define CCL_ReadBranch 0x10 /* Read one byte into a register,
266 and jump by branch table:
267 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
268 2:A--D--D--R--E-S-S[0]000XXXXX
269 3:A--D--D--R--E-S-S[1]000XXXXX
271 ------------------------------
273 if (0 <= reg[rrr] < CC..C)
274 IC += ADDRESS[reg[rrr]];
276 IC += ADDRESS[CC..C];
279 #define CCL_WriteRegister 0x11 /* Write registers:
280 1:CCCCCCCCCCCCCCCCCCCrrrXXXXX
281 2:CCCCCCCCCCCCCCCCCCCrrrXXXXX
283 ------------------------------
289 /* Note: If the Nth write is suspended, the resumed execution
290 starts from the Nth code. */
292 #define CCL_WriteExprRegister 0x12 /* Write result of expression
293 1:00000OPERATIONRrrRRR000XXXXX
294 ------------------------------
295 write (reg[RRR] OPERATION reg[Rrr]);
298 #define CCL_Call 0x13 /* Call the CCL program whose ID is
300 1:CCCCCCCCCCCCCCCCCCCC000XXXXX
301 ------------------------------
305 #define CCL_WriteConstString 0x14 /* Write a constant or a string:
306 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
307 [2:0000STRIN[0]STRIN[1]STRIN[2]]
309 -----------------------------
313 write_string (STRING, CC..C);
314 IC += (CC..C + 2) / 3;
317 #define CCL_WriteArray 0x15 /* Write an element of array:
318 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
322 ------------------------------
323 if (0 <= reg[rrr] < CC..C)
324 write (ELEMENT[reg[rrr]]);
328 #define CCL_End 0x16 /* Terminate:
329 1:00000000000000000000000XXXXX
330 ------------------------------
334 /* The following two codes execute an assignment arithmetic/logical
335 operation. The form of the operation is like REG OP= OPERAND. */
337 #define CCL_ExprSelfConst 0x17 /* REG OP= constant:
338 1:00000OPERATION000000rrrXXXXX
340 ------------------------------
341 reg[rrr] OPERATION= CONSTANT;
344 #define CCL_ExprSelfReg 0x18 /* REG1 OP= REG2:
345 1:00000OPERATION000RRRrrrXXXXX
346 ------------------------------
347 reg[rrr] OPERATION= reg[RRR];
350 /* The following codes execute an arithmetic/logical operation. The
351 form of the operation is like REG_X = REG_Y OP OPERAND2. */
353 #define CCL_SetExprConst 0x19 /* REG_X = REG_Y OP constant:
354 1:00000OPERATION000RRRrrrXXXXX
356 ------------------------------
357 reg[rrr] = reg[RRR] OPERATION CONSTANT;
361 #define CCL_SetExprReg 0x1A /* REG1 = REG2 OP REG3:
362 1:00000OPERATIONRrrRRRrrrXXXXX
363 ------------------------------
364 reg[rrr] = reg[RRR] OPERATION reg[Rrr];
367 #define CCL_JumpCondExprConst 0x1B /* Jump conditional according to
368 an operation on constant:
369 1:A--D--D--R--E--S--S-rrrXXXXX
372 -----------------------------
373 reg[7] = reg[rrr] OPERATION CONSTANT;
380 #define CCL_JumpCondExprReg 0x1C /* Jump conditional according to
381 an operation on register:
382 1:A--D--D--R--E--S--S-rrrXXXXX
385 -----------------------------
386 reg[7] = reg[rrr] OPERATION reg[RRR];
393 #define CCL_ReadJumpCondExprConst 0x1D /* Read and jump conditional according
394 to an operation on constant:
395 1:A--D--D--R--E--S--S-rrrXXXXX
398 -----------------------------
400 reg[7] = reg[rrr] OPERATION CONSTANT;
407 #define CCL_ReadJumpCondExprReg 0x1E /* Read and jump conditional according
408 to an operation on register:
409 1:A--D--D--R--E--S--S-rrrXXXXX
412 -----------------------------
414 reg[7] = reg[rrr] OPERATION reg[RRR];
421 #define CCL_Extention 0x1F /* Extended CCL code
422 1:ExtendedCOMMNDRrrRRRrrrXXXXX
425 ------------------------------
426 extended_command (rrr,RRR,Rrr,ARGS)
430 Here after, Extended CCL Instructions.
431 Bit length of extended command is 14.
432 Therefore, the instruction code range is 0..16384(0x3fff).
435 /* Read a multibyte characeter.
436 A code point is stored into reg[rrr]. A charset ID is stored into
439 #define CCL_ReadMultibyteChar2 0x00 /* Read Multibyte Character
440 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
442 /* Write a multibyte character.
443 Write a character whose code point is reg[rrr] and the charset ID
446 #define CCL_WriteMultibyteChar2 0x01 /* Write Multibyte Character
447 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
449 /* Unify a character whose code point is reg[rrr] the charset ID is
450 reg[RRR] with a unification table whose ID is reg[Rrr].
452 A unified character is set in reg[rrr] (code point) and reg[RRR]
455 #define CCL_UnifyCharacter 0x02 /* Unify Multibyte Character
456 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
458 /* Unify a character whose code point is reg[rrr] and the charset ID
459 is reg[RRR] with a unification table whose ID is ARGUMENT.
461 A unified character is set in reg[rrr] (code point) and reg[RRR]
464 #define CCL_UnifyCharacterConstTbl 0x03 /* Unify Multibyte Character
465 1:ExtendedCOMMNDRrrRRRrrrXXXXX
466 2:ARGUMENT(Unification Table ID)
469 /* Iterate looking up TABLEs for reg[rrr] starting from the Nth (N =
470 reg[RRR]) TABLE until some value is found.
472 Each TABLE is a Lisp vector whose element is number, nil, t, or
474 If the element is nil, ignore the table and proceed to the next table.
475 If the element is t or lambda, finish without changing reg[rrr].
476 If the element is a number, set reg[rrr] to the number and finish.
478 Detail of the table structure is descibed in the comment for
479 CCL_TranslateMultipleMap below. */
481 #define CCL_IterateMultipleMap 0x10 /* Iterate Multiple Map
482 1:ExtendedCOMMNDXXXRRRrrrXXXXX
489 /* Translate code point reg[rrr] by TABLEs starting from the Nth (N =
492 TABLEs are suppried in the succeeding CCL codes as follows:
494 When CCL program gives this nested structure of table to this command:
497 (TABLE-ID121 TABLE-ID122 TABLE-ID123)
500 (TABLE-ID211 (TABLE-ID2111) TABLE-ID212)
502 the compiled CCL codes has this sequence:
503 CCL_TranslateMultipleMap (CCL code of this command)
504 16 (total number of TABLEs and SEPARATERs)
522 A value of each SEPARATER follows this rule:
523 TABLE-SET := SEPARATOR [(TABLE-ID | TABLE-SET)]+
524 SEPARATOR := -(number of TABLE-IDs and SEPARATORs in the TABLE-SET)
526 (*)....Nest level of TABLE-SET must not be over than MAX_TABLE_SET_LEVEL.
528 When some table fails to translate (i.e. it doesn't have a value
529 for reg[rrr]), the translation is treated as identity.
531 The translation is iterated for all tables in each table set (set
532 of tables separators by a SEPARATOR) except the case that lambda is
533 encountered (see below).
535 Each table is a Lisp vector of the following format (a) or (b):
536 (a)......[STARTPOINT VAL1 VAL2 ...]
537 (b)......[t VAL STARTPOINT ENDPOINT],
539 STARTPOINT is an offset to be used for indexing a table,
540 ENDPOINT is a maxmum index number of a table,
541 VAL and VALn is a number, nil, t, or lambda.
543 Valid index range of a table of type (a) is:
544 STARTPOINT <= index < STARTPOINT + table_size - 1
545 Valid index range of a table of type (b) is:
546 STARTPOINT <= index < ENDPOINT
548 If VALn is nil, the table is ignored and translation proceed to the
550 In VALn is t, reg[rrr] is reverted to the original value and
551 translation proceed to the next table.
552 If VALn is lambda, translation in the current TABLE-SET finishes
553 and proceed to the upper level TABLE-SET. */
555 #define CCL_TranslateMultipleMap 0x11 /* Translate Multiple Map
556 1:ExtendedCOMMNDXXXRRRrrrXXXXX
568 #define MAX_TABLE_SET_LEVEL 20
576 static tr_stack translate_stack
[MAX_TABLE_SET_LEVEL
];
577 static tr_stack
*translate_stack_pointer
;
579 #define PUSH_TRANSLATE_STACK(restlen, orig) \
581 translate_stack_pointer->rest_length = (restlen); \
582 translate_stack_pointer->orig_val = (orig); \
583 translate_stack_pointer++; \
586 #define POP_TRANSLATE_STACK(restlen, orig) \
588 translate_stack_pointer--; \
589 (restlen) = translate_stack_pointer->rest_length; \
590 (orig) = translate_stack_pointer->orig_val; \
593 #define CCL_TranslateSingleMap 0x12 /* Translate Single Map
594 1:ExtendedCOMMNDXXXRRRrrrXXXXX
596 ------------------------------
597 Translate reg[rrr] by TABLE-ID.
598 If some valid translation is found,
599 set reg[rrr] to the result,
604 /* CCL arithmetic/logical operators. */
605 #define CCL_PLUS 0x00 /* X = Y + Z */
606 #define CCL_MINUS 0x01 /* X = Y - Z */
607 #define CCL_MUL 0x02 /* X = Y * Z */
608 #define CCL_DIV 0x03 /* X = Y / Z */
609 #define CCL_MOD 0x04 /* X = Y % Z */
610 #define CCL_AND 0x05 /* X = Y & Z */
611 #define CCL_OR 0x06 /* X = Y | Z */
612 #define CCL_XOR 0x07 /* X = Y ^ Z */
613 #define CCL_LSH 0x08 /* X = Y << Z */
614 #define CCL_RSH 0x09 /* X = Y >> Z */
615 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
616 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
617 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
618 #define CCL_LS 0x10 /* X = (X < Y) */
619 #define CCL_GT 0x11 /* X = (X > Y) */
620 #define CCL_EQ 0x12 /* X = (X == Y) */
621 #define CCL_LE 0x13 /* X = (X <= Y) */
622 #define CCL_GE 0x14 /* X = (X >= Y) */
623 #define CCL_NE 0x15 /* X = (X != Y) */
625 #define CCL_ENCODE_SJIS 0x16 /* X = HIGHER_BYTE (SJIS (Y, Z))
626 r[7] = LOWER_BYTE (SJIS (Y, Z) */
627 #define CCL_DECODE_SJIS 0x17 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
628 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
630 /* Terminate CCL program successfully. */
631 #define CCL_SUCCESS \
633 ccl->status = CCL_STAT_SUCCESS; \
634 ccl->ic = CCL_HEADER_MAIN; \
638 /* Suspend CCL program because of reading from empty input buffer or
639 writing to full output buffer. When this program is resumed, the
640 same I/O command is executed. */
641 #define CCL_SUSPEND(stat) \
644 ccl->status = stat; \
648 /* Terminate CCL program because of invalid command. Should not occur
649 in the normal case. */
650 #define CCL_INVALID_CMD \
652 ccl->status = CCL_STAT_INVALID_CMD; \
653 goto ccl_error_handler; \
656 /* Encode one character CH to multibyte form and write to the current
657 output buffer. If CH is less than 256, CH is written as is. */
658 #define CCL_WRITE_CHAR(ch) \
664 unsigned char work[4], *str; \
665 int len = CHAR_STRING (ch, work, str); \
666 if (dst + len <= (dst_bytes ? dst_end : src)) \
668 bcopy (str, dst, len); \
672 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
676 /* Write a string at ccl_prog[IC] of length LEN to the current output
678 #define CCL_WRITE_STRING(len) \
682 else if (dst + len <= (dst_bytes ? dst_end : src)) \
683 for (i = 0; i < len; i++) \
684 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
685 >> ((2 - (i % 3)) * 8)) & 0xFF; \
687 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
690 /* Read one byte from the current input buffer into Rth register. */
691 #define CCL_READ_CHAR(r) \
695 else if (src < src_end) \
697 else if (ccl->last_block) \
703 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
707 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
708 text goes to a place pointed by DESTINATION, the length of which
709 should not exceed DST_BYTES. The bytes actually processed is
710 returned as *CONSUMED. The return value is the length of the
711 resulting text. As a side effect, the contents of CCL registers
712 are updated. If SOURCE or DESTINATION is NULL, only operations on
713 registers are permitted. */
716 #define CCL_DEBUG_BACKTRACE_LEN 256
717 int ccl_backtrace_table
[CCL_BACKTRACE_TABLE
];
718 int ccl_backtrace_idx
;
721 struct ccl_prog_stack
723 Lisp_Object
*ccl_prog
; /* Pointer to an array of CCL code. */
724 int ic
; /* Instruction Counter. */
728 ccl_driver (ccl
, source
, destination
, src_bytes
, dst_bytes
, consumed
)
729 struct ccl_program
*ccl
;
730 unsigned char *source
, *destination
;
731 int src_bytes
, dst_bytes
;
734 register int *reg
= ccl
->reg
;
735 register int ic
= ccl
->ic
;
736 register int code
, field1
, field2
;
737 register Lisp_Object
*ccl_prog
= ccl
->prog
;
738 unsigned char *src
= source
, *src_end
= src
+ src_bytes
;
739 unsigned char *dst
= destination
, *dst_end
= dst
+ dst_bytes
;
743 /* For the moment, we only support depth 256 of stack. */
744 struct ccl_prog_stack ccl_prog_stack_struct
[256];
746 if (ic
>= ccl
->eof_ic
)
747 ic
= CCL_HEADER_MAIN
;
750 ccl_backtrace_idx
= 0;
756 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
757 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
758 ccl_backtrace_idx
= 0;
759 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
762 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
764 /* We can't just signal Qquit, instead break the loop as if
765 the whole data is processed. Don't reset Vquit_flag, it
766 must be handled later at a safer place. */
768 src
= source
+ src_bytes
;
769 ccl
->status
= CCL_STAT_QUIT
;
773 code
= XINT (ccl_prog
[ic
]); ic
++;
775 field2
= (code
& 0xFF) >> 5;
778 #define RRR (field1 & 7)
779 #define Rrr ((field1 >> 3) & 7)
781 #define EXCMD (field1 >> 6)
785 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
789 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
793 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
794 reg
[rrr
] = XINT (ccl_prog
[ic
]);
798 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
801 if ((unsigned int) i
< j
)
802 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
806 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
810 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
815 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
821 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
825 CCL_READ_CHAR (reg
[rrr
]);
829 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
830 i
= XINT (ccl_prog
[ic
]);
835 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
836 i
= XINT (ccl_prog
[ic
]);
839 CCL_READ_CHAR (reg
[rrr
]);
843 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
844 j
= XINT (ccl_prog
[ic
]);
846 CCL_WRITE_STRING (j
);
850 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
852 j
= XINT (ccl_prog
[ic
]);
853 if ((unsigned int) i
< j
)
855 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
859 CCL_READ_CHAR (reg
[rrr
]);
860 ic
+= ADDR
- (j
+ 2);
863 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
864 CCL_READ_CHAR (reg
[rrr
]);
868 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
869 CCL_READ_CHAR (reg
[rrr
]);
870 /* fall through ... */
871 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
872 if ((unsigned int) reg
[rrr
] < field1
)
873 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
875 ic
+= XINT (ccl_prog
[ic
+ field1
]);
878 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
881 CCL_READ_CHAR (reg
[rrr
]);
883 code
= XINT (ccl_prog
[ic
]); ic
++;
885 field2
= (code
& 0xFF) >> 5;
889 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
892 j
= XINT (ccl_prog
[ic
]);
897 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
903 code
= XINT (ccl_prog
[ic
]); ic
++;
905 field2
= (code
& 0xFF) >> 5;
909 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
916 case CCL_Call
: /* CCCCCCCCCCCCCCCCCCCC000XXXXX */
922 || field1
>= XVECTOR (Vccl_program_table
)->size
923 || (slot
= XVECTOR (Vccl_program_table
)->contents
[field1
],
925 || !VECTORP (XCONS (slot
)->cdr
))
929 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
930 ic
= ccl_prog_stack_struct
[0].ic
;
935 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
936 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
938 ccl_prog
= XVECTOR (XCONS (slot
)->cdr
)->contents
;
939 ic
= CCL_HEADER_MAIN
;
943 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
945 CCL_WRITE_CHAR (field1
);
948 CCL_WRITE_STRING (field1
);
949 ic
+= (field1
+ 2) / 3;
953 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
955 if ((unsigned int) i
< field1
)
957 j
= XINT (ccl_prog
[ic
+ i
]);
963 case CCL_End
: /* 0000000000000000000000XXXXX */
966 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
967 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
972 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
973 i
= XINT (ccl_prog
[ic
]);
978 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
985 case CCL_PLUS
: reg
[rrr
] += i
; break;
986 case CCL_MINUS
: reg
[rrr
] -= i
; break;
987 case CCL_MUL
: reg
[rrr
] *= i
; break;
988 case CCL_DIV
: reg
[rrr
] /= i
; break;
989 case CCL_MOD
: reg
[rrr
] %= i
; break;
990 case CCL_AND
: reg
[rrr
] &= i
; break;
991 case CCL_OR
: reg
[rrr
] |= i
; break;
992 case CCL_XOR
: reg
[rrr
] ^= i
; break;
993 case CCL_LSH
: reg
[rrr
] <<= i
; break;
994 case CCL_RSH
: reg
[rrr
] >>= i
; break;
995 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
996 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
997 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
998 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
999 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
1000 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
1001 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
1002 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
1003 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
1004 default: CCL_INVALID_CMD
;
1008 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1010 j
= XINT (ccl_prog
[ic
]);
1012 jump_address
= ++ic
;
1015 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1022 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1023 CCL_READ_CHAR (reg
[rrr
]);
1024 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1026 op
= XINT (ccl_prog
[ic
]);
1027 jump_address
= ic
++ + ADDR
;
1028 j
= XINT (ccl_prog
[ic
]);
1033 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1034 CCL_READ_CHAR (reg
[rrr
]);
1035 case CCL_JumpCondExprReg
:
1037 op
= XINT (ccl_prog
[ic
]);
1038 jump_address
= ic
++ + ADDR
;
1039 j
= reg
[XINT (ccl_prog
[ic
])];
1046 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1047 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1048 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1049 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1050 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1051 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1052 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1053 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1054 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1055 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1056 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1057 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1058 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1059 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1060 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1061 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1062 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1063 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1064 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1065 case CCL_ENCODE_SJIS
: ENCODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1066 case CCL_DECODE_SJIS
: DECODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1067 default: CCL_INVALID_CMD
;
1070 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1082 case CCL_ReadMultibyteChar2
:
1089 goto ccl_read_multibyte_character_suspend
;
1093 if (i
== LEADING_CODE_COMPOSITION
)
1096 goto ccl_read_multibyte_character_suspend
;
1099 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1103 ccl
->private_state
= COMPOSING_NO_RULE_HEAD
;
1105 if (ccl
->private_state
!= 0)
1107 /* composite character */
1109 ccl
->private_state
= 0;
1115 goto ccl_read_multibyte_character_suspend
;
1121 if (COMPOSING_WITH_RULE_RULE
== ccl
->private_state
)
1123 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1126 else if (COMPOSING_WITH_RULE_HEAD
== ccl
->private_state
)
1127 ccl
->private_state
= COMPOSING_WITH_RULE_RULE
;
1134 reg
[RRR
] = CHARSET_ASCII
;
1136 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION1
)
1139 goto ccl_read_multibyte_character_suspend
;
1141 reg
[rrr
] = (*src
++ & 0x7F);
1143 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION2
)
1145 if ((src
+ 1) >= src_end
)
1146 goto ccl_read_multibyte_character_suspend
;
1148 i
= (*src
++ & 0x7F);
1149 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1152 else if ((i
== LEADING_CODE_PRIVATE_11
)
1153 || (i
== LEADING_CODE_PRIVATE_12
))
1155 if ((src
+ 1) >= src_end
)
1156 goto ccl_read_multibyte_character_suspend
;
1158 reg
[rrr
] = (*src
++ & 0x7F);
1160 else if ((i
== LEADING_CODE_PRIVATE_21
)
1161 || (i
== LEADING_CODE_PRIVATE_22
))
1163 if ((src
+ 2) >= src_end
)
1164 goto ccl_read_multibyte_character_suspend
;
1166 i
= (*src
++ & 0x7F);
1167 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1173 Returned charset is -1. */
1179 ccl_read_multibyte_character_suspend
:
1181 if (ccl
->last_block
)
1187 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC
);
1191 case CCL_WriteMultibyteChar2
:
1192 i
= reg
[RRR
]; /* charset */
1193 if (i
== CHARSET_ASCII
)
1194 i
= reg
[rrr
] & 0x7F;
1195 else if (i
== CHARSET_COMPOSITION
)
1196 i
= MAKE_COMPOSITE_CHAR (reg
[rrr
]);
1197 else if (CHARSET_DIMENSION (i
) == 1)
1198 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1199 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1200 i
= ((i
- 0x8F) << 14) | reg
[rrr
];
1202 i
= ((i
- 0xE0) << 14) | reg
[rrr
];
1208 case CCL_UnifyCharacter
:
1209 i
= reg
[RRR
]; /* charset */
1210 if (i
== CHARSET_ASCII
)
1211 i
= reg
[rrr
] & 0x7F;
1212 else if (i
== CHARSET_COMPOSITION
)
1217 else if (CHARSET_DIMENSION (i
) == 1)
1218 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1219 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1220 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1222 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1224 op
= unify_char (UNIFICATION_ID_TABLE (reg
[Rrr
]), i
, -1, 0, 0);
1225 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1232 case CCL_UnifyCharacterConstTbl
:
1233 op
= XINT (ccl_prog
[ic
]); /* table */
1235 i
= reg
[RRR
]; /* charset */
1236 if (i
== CHARSET_ASCII
)
1237 i
= reg
[rrr
] & 0x7F;
1238 else if (i
== CHARSET_COMPOSITION
)
1243 else if (CHARSET_DIMENSION (i
) == 1)
1244 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1245 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1246 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1248 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1250 op
= unify_char (UNIFICATION_ID_TABLE (op
), i
, -1, 0, 0);
1251 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1258 case CCL_IterateMultipleMap
:
1260 Lisp_Object table
, content
, attrib
, value
;
1261 int point
, size
, fin_ic
;
1263 j
= XINT (ccl_prog
[ic
++]); /* number of tables. */
1266 if ((j
> reg
[RRR
]) && (j
>= 0))
1281 size
= XVECTOR (Vccl_translation_table_vector
)->size
;
1282 point
= XINT (ccl_prog
[ic
++]);
1283 if (point
>= size
) continue;
1285 XVECTOR (Vccl_translation_table_vector
)->contents
[point
];
1287 /* Check table varidity. */
1288 if (!CONSP (table
)) continue;
1289 table
= XCONS(table
)->cdr
;
1290 if (!VECTORP (table
)) continue;
1291 size
= XVECTOR (table
)->size
;
1292 if (size
<= 1) continue;
1294 content
= XVECTOR (table
)->contents
[0];
1296 /* check table type,
1297 [STARTPOINT VAL1 VAL2 ...] or
1298 [t ELELMENT STARTPOINT ENDPOINT] */
1299 if (NUMBERP (content
))
1301 point
= XUINT (content
);
1302 point
= op
- point
+ 1;
1303 if (!((point
>= 1) && (point
< size
))) continue;
1304 content
= XVECTOR (table
)->contents
[point
];
1306 else if (EQ (content
, Qt
))
1308 if (size
!= 4) continue;
1309 if ((op
>= XUINT (XVECTOR (table
)->contents
[2]))
1310 && (op
< XUINT (XVECTOR (table
)->contents
[3])))
1311 content
= XVECTOR (table
)->contents
[1];
1320 else if (NUMBERP (content
))
1323 reg
[rrr
] = XINT(content
);
1326 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1331 else if (CONSP (content
))
1333 attrib
= XCONS (content
)->car
;
1334 value
= XCONS (content
)->cdr
;
1335 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1338 reg
[rrr
] = XUINT (value
);
1348 case CCL_TranslateMultipleMap
:
1350 Lisp_Object table
, content
, attrib
, value
;
1351 int point
, size
, table_vector_size
;
1352 int table_set_rest_length
, fin_ic
;
1354 table_set_rest_length
=
1355 XINT (ccl_prog
[ic
++]); /* number of tables and separators. */
1356 fin_ic
= ic
+ table_set_rest_length
;
1357 if ((table_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1361 table_set_rest_length
-= i
;
1369 translate_stack_pointer
= translate_stack
;
1371 PUSH_TRANSLATE_STACK (0, op
);
1374 = XVECTOR (Vccl_translation_table_vector
)->size
;
1375 for (;table_set_rest_length
> 0;i
++, table_set_rest_length
--)
1377 point
= XINT(ccl_prog
[ic
++]);
1381 if (translate_stack_pointer
1382 >= &translate_stack
[MAX_TABLE_SET_LEVEL
])
1386 PUSH_TRANSLATE_STACK (table_set_rest_length
- point
,
1388 table_set_rest_length
= point
+ 1;
1393 if (point
>= table_vector_size
) continue;
1395 XVECTOR (Vccl_translation_table_vector
)->contents
[point
];
1397 /* Check table varidity. */
1398 if (!CONSP (table
)) continue;
1399 table
= XCONS (table
)->cdr
;
1400 if (!VECTORP (table
)) continue;
1401 size
= XVECTOR (table
)->size
;
1402 if (size
<= 1) continue;
1404 content
= XVECTOR (table
)->contents
[0];
1406 /* check table type,
1407 [STARTPOINT VAL1 VAL2 ...] or
1408 [t ELEMENT STARTPOINT ENDPOINT] */
1409 if (NUMBERP (content
))
1411 point
= XUINT (content
);
1412 point
= op
- point
+ 1;
1413 if (!((point
>= 1) && (point
< size
))) continue;
1414 content
= XVECTOR (table
)->contents
[point
];
1416 else if (EQ (content
, Qt
))
1418 if (size
!= 4) continue;
1419 if ((op
>= XUINT (XVECTOR (table
)->contents
[2])) &&
1420 (op
< XUINT (XVECTOR (table
)->contents
[3])))
1421 content
= XVECTOR (table
)->contents
[1];
1430 else if (NUMBERP (content
))
1432 op
= XINT (content
);
1434 i
+= table_set_rest_length
;
1435 POP_TRANSLATE_STACK (table_set_rest_length
, reg
[rrr
]);
1437 else if (CONSP (content
))
1439 attrib
= XCONS (content
)->car
;
1440 value
= XCONS (content
)->cdr
;
1441 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1445 i
+= table_set_rest_length
;
1446 POP_TRANSLATE_STACK (table_set_rest_length
, reg
[rrr
]);
1448 else if (EQ (content
, Qt
))
1452 i
+= table_set_rest_length
;
1453 POP_TRANSLATE_STACK (table_set_rest_length
, reg
[rrr
]);
1455 else if (EQ (content
, Qlambda
))
1467 case CCL_TranslateSingleMap
:
1469 Lisp_Object table
, attrib
, value
, content
;
1471 j
= XINT (ccl_prog
[ic
++]); /* table_id */
1473 if (j
>= XVECTOR (Vccl_translation_table_vector
)->size
)
1478 table
= XVECTOR (Vccl_translation_table_vector
)->contents
[j
];
1484 table
= XCONS(table
)->cdr
;
1485 if (!VECTORP (table
))
1490 size
= XVECTOR (table
)->size
;
1491 point
= XUINT (XVECTOR (table
)->contents
[0]);
1492 point
= op
- point
+ 1;
1495 (!((point
>= 1) && (point
< size
))))
1499 content
= XVECTOR (table
)->contents
[point
];
1502 else if (NUMBERP (content
))
1503 reg
[rrr
] = XINT (content
);
1504 else if (EQ (content
, Qt
))
1506 else if (CONSP (content
))
1508 attrib
= XCONS (content
)->car
;
1509 value
= XCONS (content
)->cdr
;
1510 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1512 reg
[rrr
] = XUINT(value
);
1534 /* We can insert an error message only if DESTINATION is
1535 specified and we still have a room to store the message
1540 switch (ccl
->status
)
1542 case CCL_STAT_INVALID_CMD
:
1543 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1544 code
& 0x1F, code
, ic
);
1547 int i
= ccl_backtrace_idx
- 1;
1550 msglen
= strlen (msg
);
1551 if (dst
+ msglen
<= dst_end
)
1553 bcopy (msg
, dst
, msglen
);
1557 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1559 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1560 if (ccl_backtrace_table
[i
] == 0)
1562 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1563 msglen
= strlen (msg
);
1564 if (dst
+ msglen
> dst_end
)
1566 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_end
)
1584 bcopy (msg
, dst
, msglen
);
1591 if (consumed
) *consumed
= src
- source
;
1592 return dst
- destination
;
1595 /* Setup fields of the structure pointed by CCL appropriately for the
1596 execution of compiled CCL code in VEC (vector of integer). */
1598 setup_ccl_program (ccl
, vec
)
1599 struct ccl_program
*ccl
;
1604 ccl
->size
= XVECTOR (vec
)->size
;
1605 ccl
->prog
= XVECTOR (vec
)->contents
;
1606 ccl
->ic
= CCL_HEADER_MAIN
;
1607 ccl
->eof_ic
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_EOF
]);
1608 ccl
->buf_magnification
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_BUF_MAG
]);
1609 for (i
= 0; i
< 8; i
++)
1611 ccl
->last_block
= 0;
1612 ccl
->private_state
= 0;
1616 /* Resolve symbols in the specified CCL code (Lisp vector). This
1617 function converts translation-table and unification-table symbols
1618 embeded in the CCL code into their ID numbers. */
1621 resolve_symbol_ccl_program (ccl
)
1625 Lisp_Object result
, contents
, prop
;
1628 veclen
= XVECTOR (result
)->size
;
1630 /* Set CCL program's table ID */
1631 for (i
= 0; i
< veclen
; i
++)
1633 contents
= XVECTOR (result
)->contents
[i
];
1634 if (SYMBOLP (contents
))
1636 if (EQ(result
, ccl
))
1637 result
= Fcopy_sequence (ccl
);
1639 prop
= Fget (contents
, Qunification_table_id
);
1642 XVECTOR (result
)->contents
[i
] = prop
;
1645 prop
= Fget (contents
, Qccl_translation_table_id
);
1648 XVECTOR (result
)->contents
[i
] = prop
;
1651 prop
= Fget (contents
, Qccl_program_idx
);
1654 XVECTOR (result
)->contents
[i
] = prop
;
1666 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
1667 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1669 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1670 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1671 in this case, the execution is slower).\n\
1672 No I/O commands should appear in CCL-PROGRAM.\n\
1674 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1677 As side effect, each element of REGISTERS holds the value of\n\
1678 corresponding register after the execution.")
1680 Lisp_Object ccl_prog
, reg
;
1682 struct ccl_program ccl
;
1686 if ((SYMBOLP (ccl_prog
)) &&
1687 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1689 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1690 CHECK_LIST (ccl_prog
, 0);
1691 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1692 CHECK_VECTOR (ccl_prog
, 1);
1696 CHECK_VECTOR (ccl_prog
, 1);
1697 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1700 CHECK_VECTOR (reg
, 2);
1701 if (XVECTOR (reg
)->size
!= 8)
1702 error ("Invalid length of vector REGISTERS");
1704 setup_ccl_program (&ccl
, ccl_prog
);
1705 for (i
= 0; i
< 8; i
++)
1706 ccl
.reg
[i
] = (INTEGERP (XVECTOR (reg
)->contents
[i
])
1707 ? XINT (XVECTOR (reg
)->contents
[i
])
1710 ccl_driver (&ccl
, (char *)0, (char *)0, 0, 0, (int *)0);
1712 if (ccl
.status
!= CCL_STAT_SUCCESS
)
1713 error ("Error in CCL program at %dth code", ccl
.ic
);
1715 for (i
= 0; i
< 8; i
++)
1716 XSETINT (XVECTOR (reg
)->contents
[i
], ccl
.reg
[i
]);
1720 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
1722 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
1724 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1725 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1726 in this case, the execution is slower).\n\
1728 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
1730 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
1731 R0..R7 are initial values of corresponding registers,\n\
1732 IC is the instruction counter specifying from where to start the program.\n\
1733 If R0..R7 are nil, they are initialized to 0.\n\
1734 If IC is nil, it is initialized to head of the CCL program.\n\
1736 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
1737 when read buffer is exausted, else, IC is always set to the end of\n\
1738 CCL-PROGRAM on exit.
1740 It returns the contents of write buffer as a string,\n\
1741 and as side effect, STATUS is updated.\n\
1742 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
1743 is a unibyte string. By default it is a multibyte string.")
1744 (ccl_prog
, status
, str
, contin
, unibyte_p
)
1745 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
1748 struct ccl_program ccl
;
1752 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1755 if ((SYMBOLP (ccl_prog
)) &&
1756 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1758 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1759 CHECK_LIST (ccl_prog
, 0);
1760 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1761 CHECK_VECTOR (ccl_prog
, 1);
1765 CHECK_VECTOR (ccl_prog
, 1);
1766 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1769 CHECK_VECTOR (status
, 1);
1770 if (XVECTOR (status
)->size
!= 9)
1771 error ("Invalid length of vector STATUS");
1772 CHECK_STRING (str
, 2);
1773 GCPRO3 (ccl_prog
, status
, str
);
1775 setup_ccl_program (&ccl
, ccl_prog
);
1776 for (i
= 0; i
< 8; i
++)
1778 if (NILP (XVECTOR (status
)->contents
[i
]))
1779 XSETINT (XVECTOR (status
)->contents
[i
], 0);
1780 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1781 ccl
.reg
[i
] = XINT (XVECTOR (status
)->contents
[i
]);
1783 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1785 i
= XFASTINT (XVECTOR (status
)->contents
[8]);
1786 if (ccl
.ic
< i
&& i
< ccl
.size
)
1789 outbufsize
= STRING_BYTES (XSTRING (str
)) * ccl
.buf_magnification
+ 256;
1790 outbuf
= (char *) xmalloc (outbufsize
);
1792 error ("Not enough memory");
1793 ccl
.last_block
= NILP (contin
);
1794 produced
= ccl_driver (&ccl
, XSTRING (str
)->data
, outbuf
,
1795 STRING_BYTES (XSTRING (str
)), outbufsize
, (int *)0);
1796 for (i
= 0; i
< 8; i
++)
1797 XSET (XVECTOR (status
)->contents
[i
], Lisp_Int
, ccl
.reg
[i
]);
1798 XSETINT (XVECTOR (status
)->contents
[8], ccl
.ic
);
1801 if (NILP (unibyte_p
))
1802 val
= make_string (outbuf
, produced
);
1804 val
= make_unibyte_string (outbuf
, produced
);
1807 if (ccl
.status
!= CCL_STAT_SUCCESS
1808 && ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
1809 && ccl
.status
!= CCL_STAT_SUSPEND_BY_DST
)
1810 error ("Error in CCL program at %dth code", ccl
.ic
);
1815 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
1817 "Register CCL program PROGRAM of NAME in `ccl-program-table'.\n\
1818 PROGRAM should be a compiled code of CCL program, or nil.\n\
1819 Return index number of the registered CCL program.")
1821 Lisp_Object name
, ccl_prog
;
1823 int len
= XVECTOR (Vccl_program_table
)->size
;
1826 CHECK_SYMBOL (name
, 0);
1827 if (!NILP (ccl_prog
))
1829 CHECK_VECTOR (ccl_prog
, 1);
1830 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1833 for (i
= 0; i
< len
; i
++)
1835 Lisp_Object slot
= XVECTOR (Vccl_program_table
)->contents
[i
];
1840 if (EQ (name
, XCONS (slot
)->car
))
1842 XCONS (slot
)->cdr
= ccl_prog
;
1843 return make_number (i
);
1849 Lisp_Object new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
1852 for (j
= 0; j
< len
; j
++)
1853 XVECTOR (new_table
)->contents
[j
]
1854 = XVECTOR (Vccl_program_table
)->contents
[j
];
1855 Vccl_program_table
= new_table
;
1858 XVECTOR (Vccl_program_table
)->contents
[i
] = Fcons (name
, ccl_prog
);
1859 return make_number (i
);
1862 /* register CCL translation table.
1863 CCL translation table consists of numbers and Qt and Qnil and Qlambda.
1864 The first element is start code point.
1865 The rest elements are translated numbers.
1866 Qt shows that an original number before translation.
1867 Qnil shows that an empty element.
1868 Qlambda makes translation stopped.
1871 DEFUN ("register-ccl-translation-table", Fregister_ccl_translation_table
,
1872 Sregister_ccl_translation_table
,
1874 "Register CCL translation table.\n\
1875 TABLE should be a vector. SYMBOL is used for pointing the translation table out.\n\
1876 Return index number of the registered translation table.")
1878 Lisp_Object symbol
, table
;
1880 int len
= XVECTOR (Vccl_translation_table_vector
)->size
;
1884 CHECK_SYMBOL (symbol
, 0);
1885 CHECK_VECTOR (table
, 1);
1887 for (i
= 0; i
< len
; i
++)
1889 Lisp_Object slot
= XVECTOR (Vccl_translation_table_vector
)->contents
[i
];
1894 if (EQ (symbol
, XCONS (slot
)->car
))
1896 index
= make_number (i
);
1897 XCONS (slot
)->cdr
= table
;
1898 Fput (symbol
, Qccl_translation_table
, table
);
1899 Fput (symbol
, Qccl_translation_table_id
, index
);
1906 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
1909 for (j
= 0; j
< len
; j
++)
1910 XVECTOR (new_vector
)->contents
[j
]
1911 = XVECTOR (Vccl_translation_table_vector
)->contents
[j
];
1912 Vccl_translation_table_vector
= new_vector
;
1915 index
= make_number (i
);
1916 Fput (symbol
, Qccl_translation_table
, table
);
1917 Fput (symbol
, Qccl_translation_table_id
, index
);
1918 XVECTOR (Vccl_translation_table_vector
)->contents
[i
] = Fcons (symbol
, table
);
1926 staticpro (&Vccl_program_table
);
1927 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
1929 Qccl_program
= intern ("ccl-program");
1930 staticpro (&Qccl_program
);
1932 Qccl_program_idx
= intern ("ccl-program-idx");
1933 staticpro (&Qccl_program_idx
);
1935 Qccl_translation_table
= intern ("ccl-translation-table");
1936 staticpro (&Qccl_translation_table
);
1938 Qccl_translation_table_id
= intern ("ccl-translation-table-id");
1939 staticpro (&Qccl_translation_table_id
);
1941 Qunification_table
= intern ("unification-table");
1942 staticpro (&Qunification_table
);
1944 Qunification_table_id
= intern ("unification-table-id");
1945 staticpro (&Qunification_table_id
);
1947 DEFVAR_LISP ("ccl-translation-table-vector", &Vccl_translation_table_vector
,
1948 "Where is stored translation tables for CCL program.\n\
1949 Because CCL program can't access these tables except by the index of the vector.");
1950 Vccl_translation_table_vector
= Fmake_vector (make_number (16), Qnil
);
1952 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
1953 "Alist of fontname patterns vs corresponding CCL program.\n\
1954 Each element looks like (REGEXP . CCL-CODE),\n\
1955 where CCL-CODE is a compiled CCL program.\n\
1956 When a font whose name matches REGEXP is used for displaying a character,\n\
1957 CCL-CODE is executed to calculate the code point in the font\n\
1958 from the charset number and position code(s) of the character which are set\n\
1959 in CCL registers R0, R1, and R2 before the execution.\n\
1960 The code point in the font is set in CCL registers R1 and R2\n\
1961 when the execution terminated.\n\
1962 If the font is single-byte font, the register R2 is not used.");
1963 Vfont_ccl_encoder_alist
= Qnil
;
1965 defsubr (&Sccl_execute
);
1966 defsubr (&Sccl_execute_on_string
);
1967 defsubr (&Sregister_ccl_program
);
1968 defsubr (&Sregister_ccl_translation_table
);