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. */
730 /* For the moment, we only support depth 256 of stack. */
731 static struct ccl_prog_stack ccl_prog_stack_struct
[256];
734 ccl_driver (ccl
, source
, destination
, src_bytes
, dst_bytes
, consumed
)
735 struct ccl_program
*ccl
;
736 unsigned char *source
, *destination
;
737 int src_bytes
, dst_bytes
;
740 register int *reg
= ccl
->reg
;
741 register int ic
= ccl
->ic
;
742 register int code
, field1
, field2
;
743 register Lisp_Object
*ccl_prog
= ccl
->prog
;
744 unsigned char *src
= source
, *src_end
= src
+ src_bytes
;
745 unsigned char *dst
= destination
, *dst_end
= dst
+ dst_bytes
;
748 int stack_idx
= ccl
->stack_idx
;
749 /* Instruction counter of the current CCL code. */
752 if (ic
>= ccl
->eof_ic
)
753 ic
= CCL_HEADER_MAIN
;
755 if (ccl
->buf_magnification
==0) /* We can't produce any bytes. */
759 ccl_backtrace_idx
= 0;
766 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
767 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
768 ccl_backtrace_idx
= 0;
769 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
772 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
774 /* We can't just signal Qquit, instead break the loop as if
775 the whole data is processed. Don't reset Vquit_flag, it
776 must be handled later at a safer place. */
778 src
= source
+ src_bytes
;
779 ccl
->status
= CCL_STAT_QUIT
;
784 code
= XINT (ccl_prog
[ic
]); ic
++;
786 field2
= (code
& 0xFF) >> 5;
789 #define RRR (field1 & 7)
790 #define Rrr ((field1 >> 3) & 7)
792 #define EXCMD (field1 >> 6)
796 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
800 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
804 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
805 reg
[rrr
] = XINT (ccl_prog
[ic
]);
809 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
812 if ((unsigned int) i
< j
)
813 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
817 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
821 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
826 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
832 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
836 CCL_READ_CHAR (reg
[rrr
]);
840 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
841 i
= XINT (ccl_prog
[ic
]);
846 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
847 i
= XINT (ccl_prog
[ic
]);
850 CCL_READ_CHAR (reg
[rrr
]);
854 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
855 j
= XINT (ccl_prog
[ic
]);
857 CCL_WRITE_STRING (j
);
861 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
863 j
= XINT (ccl_prog
[ic
]);
864 if ((unsigned int) i
< j
)
866 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
870 CCL_READ_CHAR (reg
[rrr
]);
871 ic
+= ADDR
- (j
+ 2);
874 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
875 CCL_READ_CHAR (reg
[rrr
]);
879 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
880 CCL_READ_CHAR (reg
[rrr
]);
881 /* fall through ... */
882 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
883 if ((unsigned int) reg
[rrr
] < field1
)
884 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
886 ic
+= XINT (ccl_prog
[ic
+ field1
]);
889 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
892 CCL_READ_CHAR (reg
[rrr
]);
894 code
= XINT (ccl_prog
[ic
]); ic
++;
896 field2
= (code
& 0xFF) >> 5;
900 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
903 j
= XINT (ccl_prog
[ic
]);
908 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
914 code
= XINT (ccl_prog
[ic
]); ic
++;
916 field2
= (code
& 0xFF) >> 5;
920 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
927 case CCL_Call
: /* CCCCCCCCCCCCCCCCCCCC000XXXXX */
933 || field1
>= XVECTOR (Vccl_program_table
)->size
934 || (slot
= XVECTOR (Vccl_program_table
)->contents
[field1
],
936 || !VECTORP (XCONS (slot
)->cdr
))
940 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
941 ic
= ccl_prog_stack_struct
[0].ic
;
946 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
947 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
949 ccl_prog
= XVECTOR (XCONS (slot
)->cdr
)->contents
;
950 ic
= CCL_HEADER_MAIN
;
954 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
956 CCL_WRITE_CHAR (field1
);
959 CCL_WRITE_STRING (field1
);
960 ic
+= (field1
+ 2) / 3;
964 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
966 if ((unsigned int) i
< field1
)
968 j
= XINT (ccl_prog
[ic
+ i
]);
974 case CCL_End
: /* 0000000000000000000000XXXXX */
977 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
978 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
983 /* ccl->ic should points to this command code again to
984 suppress further processing. */
988 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
989 i
= XINT (ccl_prog
[ic
]);
994 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
1001 case CCL_PLUS
: reg
[rrr
] += i
; break;
1002 case CCL_MINUS
: reg
[rrr
] -= i
; break;
1003 case CCL_MUL
: reg
[rrr
] *= i
; break;
1004 case CCL_DIV
: reg
[rrr
] /= i
; break;
1005 case CCL_MOD
: reg
[rrr
] %= i
; break;
1006 case CCL_AND
: reg
[rrr
] &= i
; break;
1007 case CCL_OR
: reg
[rrr
] |= i
; break;
1008 case CCL_XOR
: reg
[rrr
] ^= i
; break;
1009 case CCL_LSH
: reg
[rrr
] <<= i
; break;
1010 case CCL_RSH
: reg
[rrr
] >>= i
; break;
1011 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
1012 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
1013 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
1014 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
1015 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
1016 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
1017 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
1018 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
1019 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
1020 default: CCL_INVALID_CMD
;
1024 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1026 j
= XINT (ccl_prog
[ic
]);
1028 jump_address
= ++ic
;
1031 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1038 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1039 CCL_READ_CHAR (reg
[rrr
]);
1040 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1042 op
= XINT (ccl_prog
[ic
]);
1043 jump_address
= ic
++ + ADDR
;
1044 j
= XINT (ccl_prog
[ic
]);
1049 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1050 CCL_READ_CHAR (reg
[rrr
]);
1051 case CCL_JumpCondExprReg
:
1053 op
= XINT (ccl_prog
[ic
]);
1054 jump_address
= ic
++ + ADDR
;
1055 j
= reg
[XINT (ccl_prog
[ic
])];
1062 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1063 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1064 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1065 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1066 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1067 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1068 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1069 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1070 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1071 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1072 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1073 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1074 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1075 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1076 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1077 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1078 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1079 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1080 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1081 case CCL_DECODE_SJIS
: DECODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1082 case CCL_ENCODE_SJIS
: ENCODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1083 default: CCL_INVALID_CMD
;
1086 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1098 case CCL_ReadMultibyteChar2
:
1106 goto ccl_read_multibyte_character_suspend
;
1110 if (i
== LEADING_CODE_COMPOSITION
)
1113 goto ccl_read_multibyte_character_suspend
;
1116 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1120 ccl
->private_state
= COMPOSING_NO_RULE_HEAD
;
1124 if (ccl
->private_state
!= COMPOSING_NO
)
1126 /* composite character */
1128 ccl
->private_state
= COMPOSING_NO
;
1131 if (COMPOSING_WITH_RULE_RULE
== ccl
->private_state
)
1133 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1136 else if (COMPOSING_WITH_RULE_HEAD
== ccl
->private_state
)
1137 ccl
->private_state
= COMPOSING_WITH_RULE_RULE
;
1142 goto ccl_read_multibyte_character_suspend
;
1154 reg
[RRR
] = CHARSET_ASCII
;
1156 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION1
)
1159 goto ccl_read_multibyte_character_suspend
;
1161 reg
[rrr
] = (*src
++ & 0x7F);
1163 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION2
)
1165 if ((src
+ 1) >= src_end
)
1166 goto ccl_read_multibyte_character_suspend
;
1168 i
= (*src
++ & 0x7F);
1169 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1172 else if ((i
== LEADING_CODE_PRIVATE_11
)
1173 || (i
== LEADING_CODE_PRIVATE_12
))
1175 if ((src
+ 1) >= src_end
)
1176 goto ccl_read_multibyte_character_suspend
;
1178 reg
[rrr
] = (*src
++ & 0x7F);
1180 else if ((i
== LEADING_CODE_PRIVATE_21
)
1181 || (i
== LEADING_CODE_PRIVATE_22
))
1183 if ((src
+ 2) >= src_end
)
1184 goto ccl_read_multibyte_character_suspend
;
1186 i
= (*src
++ & 0x7F);
1187 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1192 /* INVALID CODE. Return a single byte character. */
1193 reg
[RRR
] = CHARSET_ASCII
;
1200 ccl_read_multibyte_character_suspend
:
1202 if (ccl
->last_block
)
1208 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC
);
1212 case CCL_WriteMultibyteChar2
:
1213 i
= reg
[RRR
]; /* charset */
1214 if (i
== CHARSET_ASCII
)
1215 i
= reg
[rrr
] & 0xFF;
1216 else if (i
== CHARSET_COMPOSITION
)
1217 i
= MAKE_COMPOSITE_CHAR (reg
[rrr
]);
1218 else if (CHARSET_DIMENSION (i
) == 1)
1219 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1220 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1221 i
= ((i
- 0x8F) << 14) | reg
[rrr
];
1223 i
= ((i
- 0xE0) << 14) | reg
[rrr
];
1229 case CCL_TranslateCharacter
:
1230 i
= reg
[RRR
]; /* charset */
1231 if (i
== CHARSET_ASCII
)
1233 else if (i
== CHARSET_COMPOSITION
)
1238 else if (CHARSET_DIMENSION (i
) == 1)
1239 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1240 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1241 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1243 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1245 op
= translate_char (GET_TRANSLATION_TABLE (reg
[Rrr
]),
1247 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1254 case CCL_TranslateCharacterConstTbl
:
1255 op
= XINT (ccl_prog
[ic
]); /* table */
1257 i
= reg
[RRR
]; /* charset */
1258 if (i
== CHARSET_ASCII
)
1260 else if (i
== CHARSET_COMPOSITION
)
1265 else if (CHARSET_DIMENSION (i
) == 1)
1266 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1267 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1268 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1270 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1272 op
= translate_char (GET_TRANSLATION_TABLE (op
), i
, -1, 0, 0);
1273 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1280 case CCL_IterateMultipleMap
:
1282 Lisp_Object map
, content
, attrib
, value
;
1283 int point
, size
, fin_ic
;
1285 j
= XINT (ccl_prog
[ic
++]); /* number of maps. */
1288 if ((j
> reg
[RRR
]) && (j
>= 0))
1303 size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1304 point
= XINT (ccl_prog
[ic
++]);
1305 if (point
>= size
) continue;
1307 XVECTOR (Vcode_conversion_map_vector
)->contents
[point
];
1309 /* Check map varidity. */
1310 if (!CONSP (map
)) continue;
1311 map
= XCONS(map
)->cdr
;
1312 if (!VECTORP (map
)) continue;
1313 size
= XVECTOR (map
)->size
;
1314 if (size
<= 1) continue;
1316 content
= XVECTOR (map
)->contents
[0];
1319 [STARTPOINT VAL1 VAL2 ...] or
1320 [t ELELMENT STARTPOINT ENDPOINT] */
1321 if (NUMBERP (content
))
1323 point
= XUINT (content
);
1324 point
= op
- point
+ 1;
1325 if (!((point
>= 1) && (point
< size
))) continue;
1326 content
= XVECTOR (map
)->contents
[point
];
1328 else if (EQ (content
, Qt
))
1330 if (size
!= 4) continue;
1331 if ((op
>= XUINT (XVECTOR (map
)->contents
[2]))
1332 && (op
< XUINT (XVECTOR (map
)->contents
[3])))
1333 content
= XVECTOR (map
)->contents
[1];
1342 else if (NUMBERP (content
))
1345 reg
[rrr
] = XINT(content
);
1348 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1353 else if (CONSP (content
))
1355 attrib
= XCONS (content
)->car
;
1356 value
= XCONS (content
)->cdr
;
1357 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1360 reg
[rrr
] = XUINT (value
);
1370 case CCL_MapMultiple
:
1372 Lisp_Object map
, content
, attrib
, value
;
1373 int point
, size
, map_vector_size
;
1374 int map_set_rest_length
, fin_ic
;
1376 map_set_rest_length
=
1377 XINT (ccl_prog
[ic
++]); /* number of maps and separators. */
1378 fin_ic
= ic
+ map_set_rest_length
;
1379 if ((map_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1383 map_set_rest_length
-= i
;
1391 mapping_stack_pointer
= mapping_stack
;
1393 PUSH_MAPPING_STACK (0, op
);
1395 map_vector_size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1396 for (;map_set_rest_length
> 0;i
++, map_set_rest_length
--)
1398 point
= XINT(ccl_prog
[ic
++]);
1402 if (mapping_stack_pointer
1403 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1407 PUSH_MAPPING_STACK (map_set_rest_length
- point
,
1409 map_set_rest_length
= point
+ 1;
1414 if (point
>= map_vector_size
) continue;
1415 map
= (XVECTOR (Vcode_conversion_map_vector
)
1418 /* Check map varidity. */
1419 if (!CONSP (map
)) continue;
1420 map
= XCONS (map
)->cdr
;
1421 if (!VECTORP (map
)) continue;
1422 size
= XVECTOR (map
)->size
;
1423 if (size
<= 1) continue;
1425 content
= XVECTOR (map
)->contents
[0];
1428 [STARTPOINT VAL1 VAL2 ...] or
1429 [t ELEMENT STARTPOINT ENDPOINT] */
1430 if (NUMBERP (content
))
1432 point
= XUINT (content
);
1433 point
= op
- point
+ 1;
1434 if (!((point
>= 1) && (point
< size
))) continue;
1435 content
= XVECTOR (map
)->contents
[point
];
1437 else if (EQ (content
, Qt
))
1439 if (size
!= 4) continue;
1440 if ((op
>= XUINT (XVECTOR (map
)->contents
[2])) &&
1441 (op
< XUINT (XVECTOR (map
)->contents
[3])))
1442 content
= XVECTOR (map
)->contents
[1];
1451 else if (NUMBERP (content
))
1453 op
= XINT (content
);
1455 i
+= map_set_rest_length
;
1456 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1458 else if (CONSP (content
))
1460 attrib
= XCONS (content
)->car
;
1461 value
= XCONS (content
)->cdr
;
1462 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1466 i
+= map_set_rest_length
;
1467 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1469 else if (EQ (content
, Qt
))
1473 i
+= map_set_rest_length
;
1474 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1476 else if (EQ (content
, Qlambda
))
1490 Lisp_Object map
, attrib
, value
, content
;
1492 j
= XINT (ccl_prog
[ic
++]); /* map_id */
1494 if (j
>= XVECTOR (Vcode_conversion_map_vector
)->size
)
1499 map
= XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1505 map
= XCONS(map
)->cdr
;
1511 size
= XVECTOR (map
)->size
;
1512 point
= XUINT (XVECTOR (map
)->contents
[0]);
1513 point
= op
- point
+ 1;
1516 (!((point
>= 1) && (point
< size
))))
1520 content
= XVECTOR (map
)->contents
[point
];
1523 else if (NUMBERP (content
))
1524 reg
[rrr
] = XINT (content
);
1525 else if (EQ (content
, Qt
))
1527 else if (CONSP (content
))
1529 attrib
= XCONS (content
)->car
;
1530 value
= XCONS (content
)->cdr
;
1531 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1533 reg
[rrr
] = XUINT(value
);
1555 /* We can insert an error message only if DESTINATION is
1556 specified and we still have a room to store the message
1564 switch (ccl
->status
)
1566 case CCL_STAT_INVALID_CMD
:
1567 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1568 code
& 0x1F, code
, this_ic
);
1571 int i
= ccl_backtrace_idx
- 1;
1574 msglen
= strlen (msg
);
1575 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1577 bcopy (msg
, dst
, msglen
);
1581 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1583 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1584 if (ccl_backtrace_table
[i
] == 0)
1586 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1587 msglen
= strlen (msg
);
1588 if (dst
+ msglen
> (dst_bytes
? dst_end
: src
))
1590 bcopy (msg
, dst
, msglen
);
1599 sprintf(msg
, "\nCCL: Quited.");
1603 sprintf(msg
, "\nCCL: Unknown error type (%d).", ccl
->status
);
1606 msglen
= strlen (msg
);
1607 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1609 bcopy (msg
, dst
, msglen
);
1616 ccl
->stack_idx
= stack_idx
;
1617 ccl
->prog
= ccl_prog
;
1618 if (consumed
) *consumed
= src
- source
;
1619 return (dst
? dst
- destination
: 0);
1622 /* Setup fields of the structure pointed by CCL appropriately for the
1623 execution of compiled CCL code in VEC (vector of integer).
1624 If VEC is nil, we skip setting ups based on VEC. */
1626 setup_ccl_program (ccl
, vec
)
1627 struct ccl_program
*ccl
;
1634 struct Lisp_Vector
*vp
= XVECTOR (vec
);
1636 ccl
->size
= vp
->size
;
1637 ccl
->prog
= vp
->contents
;
1638 ccl
->eof_ic
= XINT (vp
->contents
[CCL_HEADER_EOF
]);
1639 ccl
->buf_magnification
= XINT (vp
->contents
[CCL_HEADER_BUF_MAG
]);
1641 ccl
->ic
= CCL_HEADER_MAIN
;
1642 for (i
= 0; i
< 8; i
++)
1644 ccl
->last_block
= 0;
1645 ccl
->private_state
= 0;
1650 /* Resolve symbols in the specified CCL code (Lisp vector). This
1651 function converts symbols of code conversion maps and character
1652 translation tables embeded in the CCL code into their ID numbers. */
1655 resolve_symbol_ccl_program (ccl
)
1659 Lisp_Object result
, contents
, prop
;
1662 veclen
= XVECTOR (result
)->size
;
1664 /* Set CCL program's table ID */
1665 for (i
= 0; i
< veclen
; i
++)
1667 contents
= XVECTOR (result
)->contents
[i
];
1668 if (SYMBOLP (contents
))
1670 if (EQ(result
, ccl
))
1671 result
= Fcopy_sequence (ccl
);
1673 prop
= Fget (contents
, Qtranslation_table_id
);
1676 XVECTOR (result
)->contents
[i
] = prop
;
1679 prop
= Fget (contents
, Qcode_conversion_map_id
);
1682 XVECTOR (result
)->contents
[i
] = prop
;
1685 prop
= Fget (contents
, Qccl_program_idx
);
1688 XVECTOR (result
)->contents
[i
] = prop
;
1700 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
1701 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1703 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1704 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1705 in this case, the execution is slower).\n\
1706 No I/O commands should appear in CCL-PROGRAM.\n\
1708 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1711 As side effect, each element of REGISTERS holds the value of\n\
1712 corresponding register after the execution.")
1714 Lisp_Object ccl_prog
, reg
;
1716 struct ccl_program ccl
;
1720 if ((SYMBOLP (ccl_prog
)) &&
1721 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1723 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1724 CHECK_LIST (ccl_prog
, 0);
1725 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1726 CHECK_VECTOR (ccl_prog
, 1);
1730 CHECK_VECTOR (ccl_prog
, 1);
1731 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1734 CHECK_VECTOR (reg
, 2);
1735 if (XVECTOR (reg
)->size
!= 8)
1736 error ("Invalid length of vector REGISTERS");
1738 setup_ccl_program (&ccl
, ccl_prog
);
1739 for (i
= 0; i
< 8; i
++)
1740 ccl
.reg
[i
] = (INTEGERP (XVECTOR (reg
)->contents
[i
])
1741 ? XINT (XVECTOR (reg
)->contents
[i
])
1744 ccl_driver (&ccl
, (char *)0, (char *)0, 0, 0, (int *)0);
1746 if (ccl
.status
!= CCL_STAT_SUCCESS
)
1747 error ("Error in CCL program at %dth code", ccl
.ic
);
1749 for (i
= 0; i
< 8; i
++)
1750 XSETINT (XVECTOR (reg
)->contents
[i
], ccl
.reg
[i
]);
1754 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
1756 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
1758 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1759 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1760 in this case, the execution is slower).\n\
1762 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
1764 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
1765 R0..R7 are initial values of corresponding registers,\n\
1766 IC is the instruction counter specifying from where to start the program.\n\
1767 If R0..R7 are nil, they are initialized to 0.\n\
1768 If IC is nil, it is initialized to head of the CCL program.\n\
1770 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
1771 when read buffer is exausted, else, IC is always set to the end of\n\
1772 CCL-PROGRAM on exit.\n\
1774 It returns the contents of write buffer as a string,\n\
1775 and as side effect, STATUS is updated.\n\
1776 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
1777 is a unibyte string. By default it is a multibyte string.")
1778 (ccl_prog
, status
, str
, contin
, unibyte_p
)
1779 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
1782 struct ccl_program ccl
;
1786 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1789 if ((SYMBOLP (ccl_prog
)) &&
1790 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1792 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1793 CHECK_LIST (ccl_prog
, 0);
1794 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1795 CHECK_VECTOR (ccl_prog
, 1);
1799 CHECK_VECTOR (ccl_prog
, 1);
1800 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1803 CHECK_VECTOR (status
, 1);
1804 if (XVECTOR (status
)->size
!= 9)
1805 error ("Invalid length of vector STATUS");
1806 CHECK_STRING (str
, 2);
1807 GCPRO3 (ccl_prog
, status
, str
);
1809 setup_ccl_program (&ccl
, ccl_prog
);
1810 for (i
= 0; i
< 8; i
++)
1812 if (NILP (XVECTOR (status
)->contents
[i
]))
1813 XSETINT (XVECTOR (status
)->contents
[i
], 0);
1814 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1815 ccl
.reg
[i
] = XINT (XVECTOR (status
)->contents
[i
]);
1817 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1819 i
= XFASTINT (XVECTOR (status
)->contents
[8]);
1820 if (ccl
.ic
< i
&& i
< ccl
.size
)
1823 outbufsize
= STRING_BYTES (XSTRING (str
)) * ccl
.buf_magnification
+ 256;
1824 outbuf
= (char *) xmalloc (outbufsize
);
1826 error ("Not enough memory");
1827 ccl
.last_block
= NILP (contin
);
1828 produced
= ccl_driver (&ccl
, XSTRING (str
)->data
, outbuf
,
1829 STRING_BYTES (XSTRING (str
)), outbufsize
, (int *)0);
1830 for (i
= 0; i
< 8; i
++)
1831 XSET (XVECTOR (status
)->contents
[i
], Lisp_Int
, ccl
.reg
[i
]);
1832 XSETINT (XVECTOR (status
)->contents
[8], ccl
.ic
);
1835 if (NILP (unibyte_p
))
1836 val
= make_string (outbuf
, produced
);
1838 val
= make_unibyte_string (outbuf
, produced
);
1841 if (ccl
.status
!= CCL_STAT_SUCCESS
1842 && ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
1843 && ccl
.status
!= CCL_STAT_SUSPEND_BY_DST
)
1844 error ("Error in CCL program at %dth code", ccl
.ic
);
1849 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
1851 "Register CCL program PROGRAM of NAME in `ccl-program-table'.\n\
1852 PROGRAM should be a compiled code of CCL program, or nil.\n\
1853 Return index number of the registered CCL program.")
1855 Lisp_Object name
, ccl_prog
;
1857 int len
= XVECTOR (Vccl_program_table
)->size
;
1860 CHECK_SYMBOL (name
, 0);
1861 if (!NILP (ccl_prog
))
1863 CHECK_VECTOR (ccl_prog
, 1);
1864 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1867 for (i
= 0; i
< len
; i
++)
1869 Lisp_Object slot
= XVECTOR (Vccl_program_table
)->contents
[i
];
1874 if (EQ (name
, XCONS (slot
)->car
))
1876 XCONS (slot
)->cdr
= ccl_prog
;
1877 return make_number (i
);
1883 Lisp_Object new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
1886 for (j
= 0; j
< len
; j
++)
1887 XVECTOR (new_table
)->contents
[j
]
1888 = XVECTOR (Vccl_program_table
)->contents
[j
];
1889 Vccl_program_table
= new_table
;
1892 XVECTOR (Vccl_program_table
)->contents
[i
] = Fcons (name
, ccl_prog
);
1893 Fput (name
, Qccl_program_idx
, make_number (i
));
1894 return make_number (i
);
1897 /* Register code conversion map.
1898 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
1899 The first element is start code point.
1900 The rest elements are mapped numbers.
1901 Symbol t means to map to an original number before mapping.
1902 Symbol nil means that the corresponding element is empty.
1903 Symbol lambda menas to terminate mapping here.
1906 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map
,
1907 Sregister_code_conversion_map
,
1909 "Register SYMBOL as code conversion map MAP.\n\
1910 Return index number of the registered map.")
1912 Lisp_Object symbol
, map
;
1914 int len
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1918 CHECK_SYMBOL (symbol
, 0);
1919 CHECK_VECTOR (map
, 1);
1921 for (i
= 0; i
< len
; i
++)
1923 Lisp_Object slot
= XVECTOR (Vcode_conversion_map_vector
)->contents
[i
];
1928 if (EQ (symbol
, XCONS (slot
)->car
))
1930 index
= make_number (i
);
1931 XCONS (slot
)->cdr
= map
;
1932 Fput (symbol
, Qcode_conversion_map
, map
);
1933 Fput (symbol
, Qcode_conversion_map_id
, index
);
1940 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
1943 for (j
= 0; j
< len
; j
++)
1944 XVECTOR (new_vector
)->contents
[j
]
1945 = XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1946 Vcode_conversion_map_vector
= new_vector
;
1949 index
= make_number (i
);
1950 Fput (symbol
, Qcode_conversion_map
, map
);
1951 Fput (symbol
, Qcode_conversion_map_id
, index
);
1952 XVECTOR (Vcode_conversion_map_vector
)->contents
[i
] = Fcons (symbol
, map
);
1960 staticpro (&Vccl_program_table
);
1961 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
1963 Qccl_program
= intern ("ccl-program");
1964 staticpro (&Qccl_program
);
1966 Qccl_program_idx
= intern ("ccl-program-idx");
1967 staticpro (&Qccl_program_idx
);
1969 Qcode_conversion_map
= intern ("code-conversion-map");
1970 staticpro (&Qcode_conversion_map
);
1972 Qcode_conversion_map_id
= intern ("code-conversion-map-id");
1973 staticpro (&Qcode_conversion_map_id
);
1975 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector
,
1976 "Vector of code conversion maps.");
1977 Vcode_conversion_map_vector
= Fmake_vector (make_number (16), Qnil
);
1979 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
1980 "Alist of fontname patterns vs corresponding CCL program.\n\
1981 Each element looks like (REGEXP . CCL-CODE),\n\
1982 where CCL-CODE is a compiled CCL program.\n\
1983 When a font whose name matches REGEXP is used for displaying a character,\n\
1984 CCL-CODE is executed to calculate the code point in the font\n\
1985 from the charset number and position code(s) of the character which are set\n\
1986 in CCL registers R0, R1, and R2 before the execution.\n\
1987 The code point in the font is set in CCL registers R1 and R2\n\
1988 when the execution terminated.\n\
1989 If the font is single-byte font, the register R2 is not used.");
1990 Vfont_ccl_encoder_alist
= Qnil
;
1992 defsubr (&Sccl_execute
);
1993 defsubr (&Sccl_execute_on_string
);
1994 defsubr (&Sregister_ccl_program
);
1995 defsubr (&Sregister_code_conversion_map
);