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 /* This contains all code conversion map available to CCL. */
44 Lisp_Object Vcode_conversion_map_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 code conversion
54 map and their ID respectively. */
55 Lisp_Object Qcode_conversion_map
;
56 Lisp_Object Qcode_conversion_map_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 /* Vector of CCL program names vs corresponding program data. */
63 Lisp_Object Vccl_program_table
;
65 /* CCL (Code Conversion Language) is a simple language which has
66 operations on one input buffer, one output buffer, and 7 registers.
67 The syntax of CCL is described in `ccl.el'. Emacs Lisp function
68 `ccl-compile' compiles a CCL program and produces a CCL code which
69 is a vector of integers. The structure of this vector is as
70 follows: The 1st element: buffer-magnification, a factor for the
71 size of output buffer compared with the size of input buffer. The
72 2nd element: address of CCL code to be executed when encountered
73 with end of input stream. The 3rd and the remaining elements: CCL
76 /* Header of CCL compiled code */
77 #define CCL_HEADER_BUF_MAG 0
78 #define CCL_HEADER_EOF 1
79 #define CCL_HEADER_MAIN 2
81 /* CCL code is a sequence of 28-bit non-negative integers (i.e. the
82 MSB is always 0), each contains CCL command and/or arguments in the
85 |----------------- integer (28-bit) ------------------|
86 |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
87 |--constant argument--|-register-|-register-|-command-|
88 ccccccccccccccccc RRR rrr XXXXX
90 |------- relative address -------|-register-|-command-|
91 cccccccccccccccccccc rrr XXXXX
93 |------------- constant or other args ----------------|
94 cccccccccccccccccccccccccccc
96 where, `cc...c' is a non-negative integer indicating constant value
97 (the left most `c' is always 0) or an absolute jump address, `RRR'
98 and `rrr' are CCL register number, `XXXXX' is one of the following
103 Each comment fields shows one or more lines for command syntax and
104 the following lines for semantics of the command. In semantics, IC
105 stands for Instruction Counter. */
107 #define CCL_SetRegister 0x00 /* Set register a register value:
108 1:00000000000000000RRRrrrXXXXX
109 ------------------------------
113 #define CCL_SetShortConst 0x01 /* Set register a short constant value:
114 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
115 ------------------------------
116 reg[rrr] = CCCCCCCCCCCCCCCCCCC;
119 #define CCL_SetConst 0x02 /* Set register a constant value:
120 1:00000000000000000000rrrXXXXX
122 ------------------------------
127 #define CCL_SetArray 0x03 /* Set register an element of array:
128 1:CCCCCCCCCCCCCCCCCRRRrrrXXXXX
132 ------------------------------
133 if (0 <= reg[RRR] < CC..C)
134 reg[rrr] = ELEMENT[reg[RRR]];
138 #define CCL_Jump 0x04 /* Jump:
139 1:A--D--D--R--E--S--S-000XXXXX
140 ------------------------------
144 /* Note: If CC..C is greater than 0, the second code is omitted. */
146 #define CCL_JumpCond 0x05 /* Jump conditional:
147 1:A--D--D--R--E--S--S-rrrXXXXX
148 ------------------------------
154 #define CCL_WriteRegisterJump 0x06 /* Write register and jump:
155 1:A--D--D--R--E--S--S-rrrXXXXX
156 ------------------------------
161 #define CCL_WriteRegisterReadJump 0x07 /* Write register, read, and jump:
162 1:A--D--D--R--E--S--S-rrrXXXXX
163 2:A--D--D--R--E--S--S-rrrYYYYY
164 -----------------------------
170 /* Note: If read is suspended, the resumed execution starts from the
171 second code (YYYYY == CCL_ReadJump). */
173 #define CCL_WriteConstJump 0x08 /* Write constant and jump:
174 1:A--D--D--R--E--S--S-000XXXXX
176 ------------------------------
181 #define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump:
182 1:A--D--D--R--E--S--S-rrrXXXXX
184 3:A--D--D--R--E--S--S-rrrYYYYY
185 -----------------------------
191 /* Note: If read is suspended, the resumed execution starts from the
192 second code (YYYYY == CCL_ReadJump). */
194 #define CCL_WriteStringJump 0x0A /* Write string and jump:
195 1:A--D--D--R--E--S--S-000XXXXX
197 3:0000STRIN[0]STRIN[1]STRIN[2]
199 ------------------------------
200 write_string (STRING, LENGTH);
204 #define CCL_WriteArrayReadJump 0x0B /* Write an array element, read, and jump:
205 1:A--D--D--R--E--S--S-rrrXXXXX
210 N:A--D--D--R--E--S--S-rrrYYYYY
211 ------------------------------
212 if (0 <= reg[rrr] < LENGTH)
213 write (ELEMENT[reg[rrr]]);
214 IC += LENGTH + 2; (... pointing at N+1)
218 /* Note: If read is suspended, the resumed execution starts from the
219 Nth code (YYYYY == CCL_ReadJump). */
221 #define CCL_ReadJump 0x0C /* Read and jump:
222 1:A--D--D--R--E--S--S-rrrYYYYY
223 -----------------------------
228 #define CCL_Branch 0x0D /* Jump by branch table:
229 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
230 2:A--D--D--R--E-S-S[0]000XXXXX
231 3:A--D--D--R--E-S-S[1]000XXXXX
233 ------------------------------
234 if (0 <= reg[rrr] < CC..C)
235 IC += ADDRESS[reg[rrr]];
237 IC += ADDRESS[CC..C];
240 #define CCL_ReadRegister 0x0E /* Read bytes into registers:
241 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
242 2:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
244 ------------------------------
249 #define CCL_WriteExprConst 0x0F /* write result of expression:
250 1:00000OPERATION000RRR000XXXXX
252 ------------------------------
253 write (reg[RRR] OPERATION CONSTANT);
257 /* Note: If the Nth read is suspended, the resumed execution starts
258 from the Nth code. */
260 #define CCL_ReadBranch 0x10 /* Read one byte into a register,
261 and jump by branch table:
262 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
263 2:A--D--D--R--E-S-S[0]000XXXXX
264 3:A--D--D--R--E-S-S[1]000XXXXX
266 ------------------------------
268 if (0 <= reg[rrr] < CC..C)
269 IC += ADDRESS[reg[rrr]];
271 IC += ADDRESS[CC..C];
274 #define CCL_WriteRegister 0x11 /* Write registers:
275 1:CCCCCCCCCCCCCCCCCCCrrrXXXXX
276 2:CCCCCCCCCCCCCCCCCCCrrrXXXXX
278 ------------------------------
284 /* Note: If the Nth write is suspended, the resumed execution
285 starts from the Nth code. */
287 #define CCL_WriteExprRegister 0x12 /* Write result of expression
288 1:00000OPERATIONRrrRRR000XXXXX
289 ------------------------------
290 write (reg[RRR] OPERATION reg[Rrr]);
293 #define CCL_Call 0x13 /* Call the CCL program whose ID is
295 1:CCCCCCCCCCCCCCCCCCCC000XXXXX
296 ------------------------------
300 #define CCL_WriteConstString 0x14 /* Write a constant or a string:
301 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
302 [2:0000STRIN[0]STRIN[1]STRIN[2]]
304 -----------------------------
308 write_string (STRING, CC..C);
309 IC += (CC..C + 2) / 3;
312 #define CCL_WriteArray 0x15 /* Write an element of array:
313 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
317 ------------------------------
318 if (0 <= reg[rrr] < CC..C)
319 write (ELEMENT[reg[rrr]]);
323 #define CCL_End 0x16 /* Terminate:
324 1:00000000000000000000000XXXXX
325 ------------------------------
329 /* The following two codes execute an assignment arithmetic/logical
330 operation. The form of the operation is like REG OP= OPERAND. */
332 #define CCL_ExprSelfConst 0x17 /* REG OP= constant:
333 1:00000OPERATION000000rrrXXXXX
335 ------------------------------
336 reg[rrr] OPERATION= CONSTANT;
339 #define CCL_ExprSelfReg 0x18 /* REG1 OP= REG2:
340 1:00000OPERATION000RRRrrrXXXXX
341 ------------------------------
342 reg[rrr] OPERATION= reg[RRR];
345 /* The following codes execute an arithmetic/logical operation. The
346 form of the operation is like REG_X = REG_Y OP OPERAND2. */
348 #define CCL_SetExprConst 0x19 /* REG_X = REG_Y OP constant:
349 1:00000OPERATION000RRRrrrXXXXX
351 ------------------------------
352 reg[rrr] = reg[RRR] OPERATION CONSTANT;
356 #define CCL_SetExprReg 0x1A /* REG1 = REG2 OP REG3:
357 1:00000OPERATIONRrrRRRrrrXXXXX
358 ------------------------------
359 reg[rrr] = reg[RRR] OPERATION reg[Rrr];
362 #define CCL_JumpCondExprConst 0x1B /* Jump conditional according to
363 an operation on constant:
364 1:A--D--D--R--E--S--S-rrrXXXXX
367 -----------------------------
368 reg[7] = reg[rrr] OPERATION CONSTANT;
375 #define CCL_JumpCondExprReg 0x1C /* Jump conditional according to
376 an operation on register:
377 1:A--D--D--R--E--S--S-rrrXXXXX
380 -----------------------------
381 reg[7] = reg[rrr] OPERATION reg[RRR];
388 #define CCL_ReadJumpCondExprConst 0x1D /* Read and jump conditional according
389 to an operation on constant:
390 1:A--D--D--R--E--S--S-rrrXXXXX
393 -----------------------------
395 reg[7] = reg[rrr] OPERATION CONSTANT;
402 #define CCL_ReadJumpCondExprReg 0x1E /* Read and jump conditional according
403 to an operation on register:
404 1:A--D--D--R--E--S--S-rrrXXXXX
407 -----------------------------
409 reg[7] = reg[rrr] OPERATION reg[RRR];
416 #define CCL_Extention 0x1F /* Extended CCL code
417 1:ExtendedCOMMNDRrrRRRrrrXXXXX
420 ------------------------------
421 extended_command (rrr,RRR,Rrr,ARGS)
425 Here after, Extended CCL Instructions.
426 Bit length of extended command is 14.
427 Therefore, the instruction code range is 0..16384(0x3fff).
430 /* Read a multibyte characeter.
431 A code point is stored into reg[rrr]. A charset ID is stored into
434 #define CCL_ReadMultibyteChar2 0x00 /* Read Multibyte Character
435 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
437 /* Write a multibyte character.
438 Write a character whose code point is reg[rrr] and the charset ID
441 #define CCL_WriteMultibyteChar2 0x01 /* Write Multibyte Character
442 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
444 /* Translate a character whose code point is reg[rrr] and the charset
445 ID is reg[RRR] by a translation table whose ID is reg[Rrr].
447 A translated character is set in reg[rrr] (code point) and reg[RRR]
450 #define CCL_TranslateCharacter 0x02 /* Translate a multibyte character
451 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
453 /* Translate a character whose code point is reg[rrr] and the charset
454 ID is reg[RRR] by a translation table whose ID is ARGUMENT.
456 A translated character is set in reg[rrr] (code point) and reg[RRR]
459 #define CCL_TranslateCharacterConstTbl 0x03 /* Translate a multibyte character
460 1:ExtendedCOMMNDRrrRRRrrrXXXXX
461 2:ARGUMENT(Translation Table ID)
464 /* Iterate looking up MAPs for reg[rrr] starting from the Nth (N =
465 reg[RRR]) MAP until some value is found.
467 Each MAP is a Lisp vector whose element is number, nil, t, or
469 If the element is nil, ignore the map and proceed to the next map.
470 If the element is t or lambda, finish without changing reg[rrr].
471 If the element is a number, set reg[rrr] to the number and finish.
473 Detail of the map structure is descibed in the comment for
474 CCL_MapMultiple below. */
476 #define CCL_IterateMultipleMap 0x10 /* Iterate multiple maps
477 1:ExtendedCOMMNDXXXRRRrrrXXXXX
484 /* Map the code in reg[rrr] by MAPs starting from the Nth (N =
487 MAPs are supplied in the succeeding CCL codes as follows:
489 When CCL program gives this nested structure of map to this command:
492 (MAP-ID121 MAP-ID122 MAP-ID123)
495 (MAP-ID211 (MAP-ID2111) MAP-ID212)
497 the compiled CCL codes has this sequence:
498 CCL_MapMultiple (CCL code of this command)
499 16 (total number of MAPs and SEPARATORs)
517 A value of each SEPARATOR follows this rule:
518 MAP-SET := SEPARATOR [(MAP-ID | MAP-SET)]+
519 SEPARATOR := -(number of MAP-IDs and SEPARATORs in the MAP-SET)
521 (*)....Nest level of MAP-SET must not be over than MAX_MAP_SET_LEVEL.
523 When some map fails to map (i.e. it doesn't have a value for
524 reg[rrr]), the mapping is treated as identity.
526 The mapping is iterated for all maps in each map set (set of maps
527 separated by SEPARATOR) except in the case that lambda is
528 encountered. More precisely, the mapping proceeds as below:
530 At first, VAL0 is set to reg[rrr], and it is translated by the
531 first map to VAL1. Then, VAL1 is translated by the next map to
532 VAL2. This mapping is iterated until the last map is used. The
533 result of the mapping is the last value of VAL?.
535 But, when VALm is mapped to VALn and VALn is not a number, the
536 mapping proceed as below:
538 If VALn is nil, the lastest map is ignored and the mapping of VALm
539 proceed to the next map.
541 In VALn is t, VALm is reverted to reg[rrr] and the mapping of VALm
542 proceed to the next map.
544 If VALn is lambda, the whole mapping process terminates, and VALm
545 is the result of this mapping.
547 Each map is a Lisp vector of the following format (a) or (b):
548 (a)......[STARTPOINT VAL1 VAL2 ...]
549 (b)......[t VAL STARTPOINT ENDPOINT],
551 STARTPOINT is an offset to be used for indexing a map,
552 ENDPOINT is a maximum index number of a map,
553 VAL and VALn is a number, nil, t, or lambda.
555 Valid index range of a map of type (a) is:
556 STARTPOINT <= index < STARTPOINT + map_size - 1
557 Valid index range of a map of type (b) is:
558 STARTPOINT <= index < ENDPOINT */
560 #define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
561 1:ExtendedCOMMNDXXXRRRrrrXXXXX
573 #define MAX_MAP_SET_LEVEL 20
581 static tr_stack mapping_stack
[MAX_MAP_SET_LEVEL
];
582 static tr_stack
*mapping_stack_pointer
;
584 #define PUSH_MAPPING_STACK(restlen, orig) \
586 mapping_stack_pointer->rest_length = (restlen); \
587 mapping_stack_pointer->orig_val = (orig); \
588 mapping_stack_pointer++; \
591 #define POP_MAPPING_STACK(restlen, orig) \
593 mapping_stack_pointer--; \
594 (restlen) = mapping_stack_pointer->rest_length; \
595 (orig) = mapping_stack_pointer->orig_val; \
598 #define CCL_MapSingle 0x12 /* Map by single code conversion map
599 1:ExtendedCOMMNDXXXRRRrrrXXXXX
601 ------------------------------
602 Map reg[rrr] by MAP-ID.
603 If some valid mapping is found,
604 set reg[rrr] to the result,
609 /* CCL arithmetic/logical operators. */
610 #define CCL_PLUS 0x00 /* X = Y + Z */
611 #define CCL_MINUS 0x01 /* X = Y - Z */
612 #define CCL_MUL 0x02 /* X = Y * Z */
613 #define CCL_DIV 0x03 /* X = Y / Z */
614 #define CCL_MOD 0x04 /* X = Y % Z */
615 #define CCL_AND 0x05 /* X = Y & Z */
616 #define CCL_OR 0x06 /* X = Y | Z */
617 #define CCL_XOR 0x07 /* X = Y ^ Z */
618 #define CCL_LSH 0x08 /* X = Y << Z */
619 #define CCL_RSH 0x09 /* X = Y >> Z */
620 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
621 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
622 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
623 #define CCL_LS 0x10 /* X = (X < Y) */
624 #define CCL_GT 0x11 /* X = (X > Y) */
625 #define CCL_EQ 0x12 /* X = (X == Y) */
626 #define CCL_LE 0x13 /* X = (X <= Y) */
627 #define CCL_GE 0x14 /* X = (X >= Y) */
628 #define CCL_NE 0x15 /* X = (X != Y) */
630 #define CCL_DECODE_SJIS 0x16 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
631 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
632 #define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z))
633 r[7] = LOWER_BYTE (SJIS (Y, Z) */
635 /* Terminate CCL program successfully. */
636 #define CCL_SUCCESS \
638 ccl->status = CCL_STAT_SUCCESS; \
642 /* Suspend CCL program because of reading from empty input buffer or
643 writing to full output buffer. When this program is resumed, the
644 same I/O command is executed. */
645 #define CCL_SUSPEND(stat) \
648 ccl->status = stat; \
652 /* Terminate CCL program because of invalid command. Should not occur
653 in the normal case. */
654 #define CCL_INVALID_CMD \
656 ccl->status = CCL_STAT_INVALID_CMD; \
657 goto ccl_error_handler; \
660 /* Encode one character CH to multibyte form and write to the current
661 output buffer. If CH is less than 256, CH is written as is. */
662 #define CCL_WRITE_CHAR(ch) \
668 unsigned char work[4], *str; \
669 int len = CHAR_STRING (ch, work, str); \
670 if (dst + len <= (dst_bytes ? dst_end : src)) \
672 while (len--) *dst++ = *str++; \
675 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
679 /* Write a string at ccl_prog[IC] of length LEN to the current output
681 #define CCL_WRITE_STRING(len) \
685 else if (dst + len <= (dst_bytes ? dst_end : src)) \
686 for (i = 0; i < len; i++) \
687 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
688 >> ((2 - (i % 3)) * 8)) & 0xFF; \
690 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
693 /* Read one byte from the current input buffer into Rth register. */
694 #define CCL_READ_CHAR(r) \
698 else if (src < src_end) \
700 else if (ccl->last_block) \
706 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
710 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
711 text goes to a place pointed by DESTINATION, the length of which
712 should not exceed DST_BYTES. The bytes actually processed is
713 returned as *CONSUMED. The return value is the length of the
714 resulting text. As a side effect, the contents of CCL registers
715 are updated. If SOURCE or DESTINATION is NULL, only operations on
716 registers are permitted. */
719 #define CCL_DEBUG_BACKTRACE_LEN 256
720 int ccl_backtrace_table
[CCL_BACKTRACE_TABLE
];
721 int ccl_backtrace_idx
;
724 struct ccl_prog_stack
726 Lisp_Object
*ccl_prog
; /* Pointer to an array of CCL code. */
727 int ic
; /* Instruction Counter. */
731 ccl_driver (ccl
, source
, destination
, src_bytes
, dst_bytes
, consumed
)
732 struct ccl_program
*ccl
;
733 unsigned char *source
, *destination
;
734 int src_bytes
, dst_bytes
;
737 register int *reg
= ccl
->reg
;
738 register int ic
= ccl
->ic
;
739 register int code
, field1
, field2
;
740 register Lisp_Object
*ccl_prog
= ccl
->prog
;
741 unsigned char *src
= source
, *src_end
= src
+ src_bytes
;
742 unsigned char *dst
= destination
, *dst_end
= dst
+ dst_bytes
;
746 /* For the moment, we only support depth 256 of stack. */
747 struct ccl_prog_stack ccl_prog_stack_struct
[256];
748 /* Instruction counter of the current CCL code. */
751 if (ic
>= ccl
->eof_ic
)
752 ic
= CCL_HEADER_MAIN
;
754 if (ccl
->buf_magnification
==0) /* We can't produce any bytes. */
758 ccl_backtrace_idx
= 0;
765 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
766 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
767 ccl_backtrace_idx
= 0;
768 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
771 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
773 /* We can't just signal Qquit, instead break the loop as if
774 the whole data is processed. Don't reset Vquit_flag, it
775 must be handled later at a safer place. */
777 src
= source
+ src_bytes
;
778 ccl
->status
= CCL_STAT_QUIT
;
783 code
= XINT (ccl_prog
[ic
]); ic
++;
785 field2
= (code
& 0xFF) >> 5;
788 #define RRR (field1 & 7)
789 #define Rrr ((field1 >> 3) & 7)
791 #define EXCMD (field1 >> 6)
795 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
799 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
803 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
804 reg
[rrr
] = XINT (ccl_prog
[ic
]);
808 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
811 if ((unsigned int) i
< j
)
812 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
816 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
820 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
825 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
831 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
835 CCL_READ_CHAR (reg
[rrr
]);
839 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
840 i
= XINT (ccl_prog
[ic
]);
845 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
846 i
= XINT (ccl_prog
[ic
]);
849 CCL_READ_CHAR (reg
[rrr
]);
853 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
854 j
= XINT (ccl_prog
[ic
]);
856 CCL_WRITE_STRING (j
);
860 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
862 j
= XINT (ccl_prog
[ic
]);
863 if ((unsigned int) i
< j
)
865 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
869 CCL_READ_CHAR (reg
[rrr
]);
870 ic
+= ADDR
- (j
+ 2);
873 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
874 CCL_READ_CHAR (reg
[rrr
]);
878 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
879 CCL_READ_CHAR (reg
[rrr
]);
880 /* fall through ... */
881 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
882 if ((unsigned int) reg
[rrr
] < field1
)
883 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
885 ic
+= XINT (ccl_prog
[ic
+ field1
]);
888 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
891 CCL_READ_CHAR (reg
[rrr
]);
893 code
= XINT (ccl_prog
[ic
]); ic
++;
895 field2
= (code
& 0xFF) >> 5;
899 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
902 j
= XINT (ccl_prog
[ic
]);
907 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
913 code
= XINT (ccl_prog
[ic
]); ic
++;
915 field2
= (code
& 0xFF) >> 5;
919 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
926 case CCL_Call
: /* CCCCCCCCCCCCCCCCCCCC000XXXXX */
932 || field1
>= XVECTOR (Vccl_program_table
)->size
933 || (slot
= XVECTOR (Vccl_program_table
)->contents
[field1
],
935 || !VECTORP (XCONS (slot
)->cdr
))
939 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
940 ic
= ccl_prog_stack_struct
[0].ic
;
945 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
946 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
948 ccl_prog
= XVECTOR (XCONS (slot
)->cdr
)->contents
;
949 ic
= CCL_HEADER_MAIN
;
953 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
955 CCL_WRITE_CHAR (field1
);
958 CCL_WRITE_STRING (field1
);
959 ic
+= (field1
+ 2) / 3;
963 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
965 if ((unsigned int) i
< field1
)
967 j
= XINT (ccl_prog
[ic
+ i
]);
973 case CCL_End
: /* 0000000000000000000000XXXXX */
976 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
977 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
982 /* ccl->ic should points to this command code again to
983 suppress further processing. */
987 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
988 i
= XINT (ccl_prog
[ic
]);
993 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
1000 case CCL_PLUS
: reg
[rrr
] += i
; break;
1001 case CCL_MINUS
: reg
[rrr
] -= i
; break;
1002 case CCL_MUL
: reg
[rrr
] *= i
; break;
1003 case CCL_DIV
: reg
[rrr
] /= i
; break;
1004 case CCL_MOD
: reg
[rrr
] %= i
; break;
1005 case CCL_AND
: reg
[rrr
] &= i
; break;
1006 case CCL_OR
: reg
[rrr
] |= i
; break;
1007 case CCL_XOR
: reg
[rrr
] ^= i
; break;
1008 case CCL_LSH
: reg
[rrr
] <<= i
; break;
1009 case CCL_RSH
: reg
[rrr
] >>= i
; break;
1010 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
1011 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
1012 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
1013 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
1014 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
1015 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
1016 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
1017 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
1018 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
1019 default: CCL_INVALID_CMD
;
1023 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1025 j
= XINT (ccl_prog
[ic
]);
1027 jump_address
= ++ic
;
1030 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1037 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1038 CCL_READ_CHAR (reg
[rrr
]);
1039 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1041 op
= XINT (ccl_prog
[ic
]);
1042 jump_address
= ic
++ + ADDR
;
1043 j
= XINT (ccl_prog
[ic
]);
1048 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1049 CCL_READ_CHAR (reg
[rrr
]);
1050 case CCL_JumpCondExprReg
:
1052 op
= XINT (ccl_prog
[ic
]);
1053 jump_address
= ic
++ + ADDR
;
1054 j
= reg
[XINT (ccl_prog
[ic
])];
1061 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1062 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1063 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1064 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1065 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1066 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1067 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1068 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1069 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1070 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1071 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1072 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1073 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1074 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1075 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1076 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1077 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1078 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1079 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1080 case CCL_DECODE_SJIS
: DECODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1081 case CCL_ENCODE_SJIS
: ENCODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1082 default: CCL_INVALID_CMD
;
1085 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1097 case CCL_ReadMultibyteChar2
:
1104 goto ccl_read_multibyte_character_suspend
;
1108 if (i
== LEADING_CODE_COMPOSITION
)
1111 goto ccl_read_multibyte_character_suspend
;
1114 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1118 ccl
->private_state
= COMPOSING_NO_RULE_HEAD
;
1120 if (ccl
->private_state
!= 0)
1122 /* composite character */
1124 ccl
->private_state
= 0;
1130 goto ccl_read_multibyte_character_suspend
;
1136 if (COMPOSING_WITH_RULE_RULE
== ccl
->private_state
)
1138 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1141 else if (COMPOSING_WITH_RULE_HEAD
== ccl
->private_state
)
1142 ccl
->private_state
= COMPOSING_WITH_RULE_RULE
;
1149 reg
[RRR
] = CHARSET_ASCII
;
1151 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION1
)
1154 goto ccl_read_multibyte_character_suspend
;
1156 reg
[rrr
] = (*src
++ & 0x7F);
1158 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION2
)
1160 if ((src
+ 1) >= src_end
)
1161 goto ccl_read_multibyte_character_suspend
;
1163 i
= (*src
++ & 0x7F);
1164 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1167 else if ((i
== LEADING_CODE_PRIVATE_11
)
1168 || (i
== LEADING_CODE_PRIVATE_12
))
1170 if ((src
+ 1) >= src_end
)
1171 goto ccl_read_multibyte_character_suspend
;
1173 reg
[rrr
] = (*src
++ & 0x7F);
1175 else if ((i
== LEADING_CODE_PRIVATE_21
)
1176 || (i
== LEADING_CODE_PRIVATE_22
))
1178 if ((src
+ 2) >= src_end
)
1179 goto ccl_read_multibyte_character_suspend
;
1181 i
= (*src
++ & 0x7F);
1182 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1187 /* INVALID CODE. Return a single byte character. */
1188 reg
[RRR
] = CHARSET_ASCII
;
1194 ccl_read_multibyte_character_suspend
:
1196 if (ccl
->last_block
)
1202 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC
);
1206 case CCL_WriteMultibyteChar2
:
1207 i
= reg
[RRR
]; /* charset */
1208 if (i
== CHARSET_ASCII
)
1209 i
= reg
[rrr
] & 0x7F;
1210 else if (i
== CHARSET_COMPOSITION
)
1211 i
= MAKE_COMPOSITE_CHAR (reg
[rrr
]);
1212 else if (CHARSET_DIMENSION (i
) == 1)
1213 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1214 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1215 i
= ((i
- 0x8F) << 14) | reg
[rrr
];
1217 i
= ((i
- 0xE0) << 14) | reg
[rrr
];
1223 case CCL_TranslateCharacter
:
1224 i
= reg
[RRR
]; /* charset */
1225 if (i
== CHARSET_ASCII
)
1227 else if (i
== CHARSET_COMPOSITION
)
1232 else if (CHARSET_DIMENSION (i
) == 1)
1233 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1234 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1235 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1237 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1239 op
= translate_char (GET_TRANSLATION_TABLE (reg
[Rrr
]),
1241 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1248 case CCL_TranslateCharacterConstTbl
:
1249 op
= XINT (ccl_prog
[ic
]); /* table */
1251 i
= reg
[RRR
]; /* charset */
1252 if (i
== CHARSET_ASCII
)
1254 else if (i
== CHARSET_COMPOSITION
)
1259 else if (CHARSET_DIMENSION (i
) == 1)
1260 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1261 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1262 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1264 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1266 op
= translate_char (GET_TRANSLATION_TABLE (op
), i
, -1, 0, 0);
1267 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1274 case CCL_IterateMultipleMap
:
1276 Lisp_Object map
, content
, attrib
, value
;
1277 int point
, size
, fin_ic
;
1279 j
= XINT (ccl_prog
[ic
++]); /* number of maps. */
1282 if ((j
> reg
[RRR
]) && (j
>= 0))
1297 size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1298 point
= XINT (ccl_prog
[ic
++]);
1299 if (point
>= size
) continue;
1301 XVECTOR (Vcode_conversion_map_vector
)->contents
[point
];
1303 /* Check map varidity. */
1304 if (!CONSP (map
)) continue;
1305 map
= XCONS(map
)->cdr
;
1306 if (!VECTORP (map
)) continue;
1307 size
= XVECTOR (map
)->size
;
1308 if (size
<= 1) continue;
1310 content
= XVECTOR (map
)->contents
[0];
1313 [STARTPOINT VAL1 VAL2 ...] or
1314 [t ELELMENT STARTPOINT ENDPOINT] */
1315 if (NUMBERP (content
))
1317 point
= XUINT (content
);
1318 point
= op
- point
+ 1;
1319 if (!((point
>= 1) && (point
< size
))) continue;
1320 content
= XVECTOR (map
)->contents
[point
];
1322 else if (EQ (content
, Qt
))
1324 if (size
!= 4) continue;
1325 if ((op
>= XUINT (XVECTOR (map
)->contents
[2]))
1326 && (op
< XUINT (XVECTOR (map
)->contents
[3])))
1327 content
= XVECTOR (map
)->contents
[1];
1336 else if (NUMBERP (content
))
1339 reg
[rrr
] = XINT(content
);
1342 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1347 else if (CONSP (content
))
1349 attrib
= XCONS (content
)->car
;
1350 value
= XCONS (content
)->cdr
;
1351 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1354 reg
[rrr
] = XUINT (value
);
1364 case CCL_MapMultiple
:
1366 Lisp_Object map
, content
, attrib
, value
;
1367 int point
, size
, map_vector_size
;
1368 int map_set_rest_length
, fin_ic
;
1370 map_set_rest_length
=
1371 XINT (ccl_prog
[ic
++]); /* number of maps and separators. */
1372 fin_ic
= ic
+ map_set_rest_length
;
1373 if ((map_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1377 map_set_rest_length
-= i
;
1385 mapping_stack_pointer
= mapping_stack
;
1387 PUSH_MAPPING_STACK (0, op
);
1389 map_vector_size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1390 for (;map_set_rest_length
> 0;i
++, map_set_rest_length
--)
1392 point
= XINT(ccl_prog
[ic
++]);
1396 if (mapping_stack_pointer
1397 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1401 PUSH_MAPPING_STACK (map_set_rest_length
- point
,
1403 map_set_rest_length
= point
+ 1;
1408 if (point
>= map_vector_size
) continue;
1409 map
= (XVECTOR (Vcode_conversion_map_vector
)
1412 /* Check map varidity. */
1413 if (!CONSP (map
)) continue;
1414 map
= XCONS (map
)->cdr
;
1415 if (!VECTORP (map
)) continue;
1416 size
= XVECTOR (map
)->size
;
1417 if (size
<= 1) continue;
1419 content
= XVECTOR (map
)->contents
[0];
1422 [STARTPOINT VAL1 VAL2 ...] or
1423 [t ELEMENT STARTPOINT ENDPOINT] */
1424 if (NUMBERP (content
))
1426 point
= XUINT (content
);
1427 point
= op
- point
+ 1;
1428 if (!((point
>= 1) && (point
< size
))) continue;
1429 content
= XVECTOR (map
)->contents
[point
];
1431 else if (EQ (content
, Qt
))
1433 if (size
!= 4) continue;
1434 if ((op
>= XUINT (XVECTOR (map
)->contents
[2])) &&
1435 (op
< XUINT (XVECTOR (map
)->contents
[3])))
1436 content
= XVECTOR (map
)->contents
[1];
1445 else if (NUMBERP (content
))
1447 op
= XINT (content
);
1449 i
+= map_set_rest_length
;
1450 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1452 else if (CONSP (content
))
1454 attrib
= XCONS (content
)->car
;
1455 value
= XCONS (content
)->cdr
;
1456 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1460 i
+= map_set_rest_length
;
1461 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1463 else if (EQ (content
, Qt
))
1467 i
+= map_set_rest_length
;
1468 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1470 else if (EQ (content
, Qlambda
))
1484 Lisp_Object map
, attrib
, value
, content
;
1486 j
= XINT (ccl_prog
[ic
++]); /* map_id */
1488 if (j
>= XVECTOR (Vcode_conversion_map_vector
)->size
)
1493 map
= XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1499 map
= XCONS(map
)->cdr
;
1505 size
= XVECTOR (map
)->size
;
1506 point
= XUINT (XVECTOR (map
)->contents
[0]);
1507 point
= op
- point
+ 1;
1510 (!((point
>= 1) && (point
< size
))))
1514 content
= XVECTOR (map
)->contents
[point
];
1517 else if (NUMBERP (content
))
1518 reg
[rrr
] = XINT (content
);
1519 else if (EQ (content
, Qt
))
1521 else if (CONSP (content
))
1523 attrib
= XCONS (content
)->car
;
1524 value
= XCONS (content
)->cdr
;
1525 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1527 reg
[rrr
] = XUINT(value
);
1549 /* We can insert an error message only if DESTINATION is
1550 specified and we still have a room to store the message
1558 switch (ccl
->status
)
1560 case CCL_STAT_INVALID_CMD
:
1561 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1562 code
& 0x1F, code
, this_ic
);
1565 int i
= ccl_backtrace_idx
- 1;
1568 msglen
= strlen (msg
);
1569 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1571 bcopy (msg
, dst
, msglen
);
1575 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1577 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1578 if (ccl_backtrace_table
[i
] == 0)
1580 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1581 msglen
= strlen (msg
);
1582 if (dst
+ msglen
> (dst_bytes
? dst_end
: src
))
1584 bcopy (msg
, dst
, msglen
);
1593 sprintf(msg
, "\nCCL: Quited.");
1597 sprintf(msg
, "\nCCL: Unknown error type (%d).", ccl
->status
);
1600 msglen
= strlen (msg
);
1601 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1603 bcopy (msg
, dst
, msglen
);
1610 if (consumed
) *consumed
= src
- source
;
1611 return (dst
? dst
- destination
: 0);
1614 /* Setup fields of the structure pointed by CCL appropriately for the
1615 execution of compiled CCL code in VEC (vector of integer).
1616 If VEC is nil, we skip setting ups based on VEC. */
1618 setup_ccl_program (ccl
, vec
)
1619 struct ccl_program
*ccl
;
1626 struct Lisp_Vector
*vp
= XVECTOR (vec
);
1628 ccl
->size
= vp
->size
;
1629 ccl
->prog
= vp
->contents
;
1630 ccl
->eof_ic
= XINT (vp
->contents
[CCL_HEADER_EOF
]);
1631 ccl
->buf_magnification
= XINT (vp
->contents
[CCL_HEADER_BUF_MAG
]);
1633 ccl
->ic
= CCL_HEADER_MAIN
;
1634 for (i
= 0; i
< 8; i
++)
1636 ccl
->last_block
= 0;
1637 ccl
->private_state
= 0;
1641 /* Resolve symbols in the specified CCL code (Lisp vector). This
1642 function converts symbols of code conversion maps and character
1643 translation tables embeded in the CCL code into their ID numbers. */
1646 resolve_symbol_ccl_program (ccl
)
1650 Lisp_Object result
, contents
, prop
;
1653 veclen
= XVECTOR (result
)->size
;
1655 /* Set CCL program's table ID */
1656 for (i
= 0; i
< veclen
; i
++)
1658 contents
= XVECTOR (result
)->contents
[i
];
1659 if (SYMBOLP (contents
))
1661 if (EQ(result
, ccl
))
1662 result
= Fcopy_sequence (ccl
);
1664 prop
= Fget (contents
, Qtranslation_table_id
);
1667 XVECTOR (result
)->contents
[i
] = prop
;
1670 prop
= Fget (contents
, Qcode_conversion_map_id
);
1673 XVECTOR (result
)->contents
[i
] = prop
;
1676 prop
= Fget (contents
, Qccl_program_idx
);
1679 XVECTOR (result
)->contents
[i
] = prop
;
1691 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
1692 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1694 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1695 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1696 in this case, the execution is slower).\n\
1697 No I/O commands should appear in CCL-PROGRAM.\n\
1699 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1702 As side effect, each element of REGISTERS holds the value of\n\
1703 corresponding register after the execution.")
1705 Lisp_Object ccl_prog
, reg
;
1707 struct ccl_program ccl
;
1711 if ((SYMBOLP (ccl_prog
)) &&
1712 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1714 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1715 CHECK_LIST (ccl_prog
, 0);
1716 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1717 CHECK_VECTOR (ccl_prog
, 1);
1721 CHECK_VECTOR (ccl_prog
, 1);
1722 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1725 CHECK_VECTOR (reg
, 2);
1726 if (XVECTOR (reg
)->size
!= 8)
1727 error ("Invalid length of vector REGISTERS");
1729 setup_ccl_program (&ccl
, ccl_prog
);
1730 for (i
= 0; i
< 8; i
++)
1731 ccl
.reg
[i
] = (INTEGERP (XVECTOR (reg
)->contents
[i
])
1732 ? XINT (XVECTOR (reg
)->contents
[i
])
1735 ccl_driver (&ccl
, (char *)0, (char *)0, 0, 0, (int *)0);
1737 if (ccl
.status
!= CCL_STAT_SUCCESS
)
1738 error ("Error in CCL program at %dth code", ccl
.ic
);
1740 for (i
= 0; i
< 8; i
++)
1741 XSETINT (XVECTOR (reg
)->contents
[i
], ccl
.reg
[i
]);
1745 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
1747 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
1749 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1750 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1751 in this case, the execution is slower).\n\
1753 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
1755 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
1756 R0..R7 are initial values of corresponding registers,\n\
1757 IC is the instruction counter specifying from where to start the program.\n\
1758 If R0..R7 are nil, they are initialized to 0.\n\
1759 If IC is nil, it is initialized to head of the CCL program.\n\
1761 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
1762 when read buffer is exausted, else, IC is always set to the end of\n\
1763 CCL-PROGRAM on exit.\n\
1765 It returns the contents of write buffer as a string,\n\
1766 and as side effect, STATUS is updated.\n\
1767 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
1768 is a unibyte string. By default it is a multibyte string.")
1769 (ccl_prog
, status
, str
, contin
, unibyte_p
)
1770 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
1773 struct ccl_program ccl
;
1777 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1780 if ((SYMBOLP (ccl_prog
)) &&
1781 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1783 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1784 CHECK_LIST (ccl_prog
, 0);
1785 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1786 CHECK_VECTOR (ccl_prog
, 1);
1790 CHECK_VECTOR (ccl_prog
, 1);
1791 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1794 CHECK_VECTOR (status
, 1);
1795 if (XVECTOR (status
)->size
!= 9)
1796 error ("Invalid length of vector STATUS");
1797 CHECK_STRING (str
, 2);
1798 GCPRO3 (ccl_prog
, status
, str
);
1800 setup_ccl_program (&ccl
, ccl_prog
);
1801 for (i
= 0; i
< 8; i
++)
1803 if (NILP (XVECTOR (status
)->contents
[i
]))
1804 XSETINT (XVECTOR (status
)->contents
[i
], 0);
1805 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1806 ccl
.reg
[i
] = XINT (XVECTOR (status
)->contents
[i
]);
1808 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1810 i
= XFASTINT (XVECTOR (status
)->contents
[8]);
1811 if (ccl
.ic
< i
&& i
< ccl
.size
)
1814 outbufsize
= STRING_BYTES (XSTRING (str
)) * ccl
.buf_magnification
+ 256;
1815 outbuf
= (char *) xmalloc (outbufsize
);
1817 error ("Not enough memory");
1818 ccl
.last_block
= NILP (contin
);
1819 produced
= ccl_driver (&ccl
, XSTRING (str
)->data
, outbuf
,
1820 STRING_BYTES (XSTRING (str
)), outbufsize
, (int *)0);
1821 for (i
= 0; i
< 8; i
++)
1822 XSET (XVECTOR (status
)->contents
[i
], Lisp_Int
, ccl
.reg
[i
]);
1823 XSETINT (XVECTOR (status
)->contents
[8], ccl
.ic
);
1826 if (NILP (unibyte_p
))
1827 val
= make_string (outbuf
, produced
);
1829 val
= make_unibyte_string (outbuf
, produced
);
1832 if (ccl
.status
!= CCL_STAT_SUCCESS
1833 && ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
1834 && ccl
.status
!= CCL_STAT_SUSPEND_BY_DST
)
1835 error ("Error in CCL program at %dth code", ccl
.ic
);
1840 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
1842 "Register CCL program PROGRAM of NAME in `ccl-program-table'.\n\
1843 PROGRAM should be a compiled code of CCL program, or nil.\n\
1844 Return index number of the registered CCL program.")
1846 Lisp_Object name
, ccl_prog
;
1848 int len
= XVECTOR (Vccl_program_table
)->size
;
1851 CHECK_SYMBOL (name
, 0);
1852 if (!NILP (ccl_prog
))
1854 CHECK_VECTOR (ccl_prog
, 1);
1855 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1858 for (i
= 0; i
< len
; i
++)
1860 Lisp_Object slot
= XVECTOR (Vccl_program_table
)->contents
[i
];
1865 if (EQ (name
, XCONS (slot
)->car
))
1867 XCONS (slot
)->cdr
= ccl_prog
;
1868 return make_number (i
);
1874 Lisp_Object new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
1877 for (j
= 0; j
< len
; j
++)
1878 XVECTOR (new_table
)->contents
[j
]
1879 = XVECTOR (Vccl_program_table
)->contents
[j
];
1880 Vccl_program_table
= new_table
;
1883 XVECTOR (Vccl_program_table
)->contents
[i
] = Fcons (name
, ccl_prog
);
1884 Fput (name
, Qccl_program_idx
, make_number (i
));
1885 return make_number (i
);
1888 /* Register code conversion map.
1889 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
1890 The first element is start code point.
1891 The rest elements are mapped numbers.
1892 Symbol t means to map to an original number before mapping.
1893 Symbol nil means that the corresponding element is empty.
1894 Symbol lambda menas to terminate mapping here.
1897 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map
,
1898 Sregister_code_conversion_map
,
1900 "Register SYMBOL as code conversion map MAP.\n\
1901 Return index number of the registered map.")
1903 Lisp_Object symbol
, map
;
1905 int len
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1909 CHECK_SYMBOL (symbol
, 0);
1910 CHECK_VECTOR (map
, 1);
1912 for (i
= 0; i
< len
; i
++)
1914 Lisp_Object slot
= XVECTOR (Vcode_conversion_map_vector
)->contents
[i
];
1919 if (EQ (symbol
, XCONS (slot
)->car
))
1921 index
= make_number (i
);
1922 XCONS (slot
)->cdr
= map
;
1923 Fput (symbol
, Qcode_conversion_map
, map
);
1924 Fput (symbol
, Qcode_conversion_map_id
, index
);
1931 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
1934 for (j
= 0; j
< len
; j
++)
1935 XVECTOR (new_vector
)->contents
[j
]
1936 = XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1937 Vcode_conversion_map_vector
= new_vector
;
1940 index
= make_number (i
);
1941 Fput (symbol
, Qcode_conversion_map
, map
);
1942 Fput (symbol
, Qcode_conversion_map_id
, index
);
1943 XVECTOR (Vcode_conversion_map_vector
)->contents
[i
] = Fcons (symbol
, map
);
1951 staticpro (&Vccl_program_table
);
1952 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
1954 Qccl_program
= intern ("ccl-program");
1955 staticpro (&Qccl_program
);
1957 Qccl_program_idx
= intern ("ccl-program-idx");
1958 staticpro (&Qccl_program_idx
);
1960 Qcode_conversion_map
= intern ("code-conversion-map");
1961 staticpro (&Qcode_conversion_map
);
1963 Qcode_conversion_map_id
= intern ("code-conversion-map-id");
1964 staticpro (&Qcode_conversion_map_id
);
1966 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector
,
1967 "Vector of code conversion maps.");
1968 Vcode_conversion_map_vector
= Fmake_vector (make_number (16), Qnil
);
1970 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
1971 "Alist of fontname patterns vs corresponding CCL program.\n\
1972 Each element looks like (REGEXP . CCL-CODE),\n\
1973 where CCL-CODE is a compiled CCL program.\n\
1974 When a font whose name matches REGEXP is used for displaying a character,\n\
1975 CCL-CODE is executed to calculate the code point in the font\n\
1976 from the charset number and position code(s) of the character which are set\n\
1977 in CCL registers R0, R1, and R2 before the execution.\n\
1978 The code point in the font is set in CCL registers R1 and R2\n\
1979 when the execution terminated.\n\
1980 If the font is single-byte font, the register R2 is not used.");
1981 Vfont_ccl_encoder_alist
= Qnil
;
1983 defsubr (&Sccl_execute
);
1984 defsubr (&Sccl_execute_on_string
);
1985 defsubr (&Sregister_ccl_program
);
1986 defsubr (&Sregister_code_conversion_map
);