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_ENCODE_SJIS 0x16 /* X = HIGHER_BYTE (SJIS (Y, Z))
631 r[7] = LOWER_BYTE (SJIS (Y, Z) */
632 #define CCL_DECODE_SJIS 0x17 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
633 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
635 /* Terminate CCL program successfully. */
636 #define CCL_SUCCESS \
638 ccl->status = CCL_STAT_SUCCESS; \
639 ccl->ic = CCL_HEADER_MAIN; \
643 /* Suspend CCL program because of reading from empty input buffer or
644 writing to full output buffer. When this program is resumed, the
645 same I/O command is executed. */
646 #define CCL_SUSPEND(stat) \
649 ccl->status = stat; \
653 /* Terminate CCL program because of invalid command. Should not occur
654 in the normal case. */
655 #define CCL_INVALID_CMD \
657 ccl->status = CCL_STAT_INVALID_CMD; \
658 goto ccl_error_handler; \
661 /* Encode one character CH to multibyte form and write to the current
662 output buffer. If CH is less than 256, CH is written as is. */
663 #define CCL_WRITE_CHAR(ch) \
669 unsigned char work[4], *str; \
670 int len = CHAR_STRING (ch, work, str); \
671 if (dst + len <= (dst_bytes ? dst_end : src)) \
673 while (len--) *dst++ = *str++; \
676 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
680 /* Write a string at ccl_prog[IC] of length LEN to the current output
682 #define CCL_WRITE_STRING(len) \
686 else if (dst + len <= (dst_bytes ? dst_end : src)) \
687 for (i = 0; i < len; i++) \
688 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
689 >> ((2 - (i % 3)) * 8)) & 0xFF; \
691 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
694 /* Read one byte from the current input buffer into Rth register. */
695 #define CCL_READ_CHAR(r) \
699 else if (src < src_end) \
701 else if (ccl->last_block) \
707 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
711 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
712 text goes to a place pointed by DESTINATION, the length of which
713 should not exceed DST_BYTES. The bytes actually processed is
714 returned as *CONSUMED. The return value is the length of the
715 resulting text. As a side effect, the contents of CCL registers
716 are updated. If SOURCE or DESTINATION is NULL, only operations on
717 registers are permitted. */
720 #define CCL_DEBUG_BACKTRACE_LEN 256
721 int ccl_backtrace_table
[CCL_BACKTRACE_TABLE
];
722 int ccl_backtrace_idx
;
725 struct ccl_prog_stack
727 Lisp_Object
*ccl_prog
; /* Pointer to an array of CCL code. */
728 int ic
; /* Instruction Counter. */
732 ccl_driver (ccl
, source
, destination
, src_bytes
, dst_bytes
, consumed
)
733 struct ccl_program
*ccl
;
734 unsigned char *source
, *destination
;
735 int src_bytes
, dst_bytes
;
738 register int *reg
= ccl
->reg
;
739 register int ic
= ccl
->ic
;
740 register int code
, field1
, field2
;
741 register Lisp_Object
*ccl_prog
= ccl
->prog
;
742 unsigned char *src
= source
, *src_end
= src
+ src_bytes
;
743 unsigned char *dst
= destination
, *dst_end
= dst
+ dst_bytes
;
747 /* For the moment, we only support depth 256 of stack. */
748 struct ccl_prog_stack ccl_prog_stack_struct
[256];
750 if (ic
>= ccl
->eof_ic
)
751 ic
= CCL_HEADER_MAIN
;
753 if (ccl
->buf_magnification
==0) /* We can't produce any bytes. */
757 ccl_backtrace_idx
= 0;
764 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
765 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
766 ccl_backtrace_idx
= 0;
767 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
770 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
772 /* We can't just signal Qquit, instead break the loop as if
773 the whole data is processed. Don't reset Vquit_flag, it
774 must be handled later at a safer place. */
776 src
= source
+ src_bytes
;
777 ccl
->status
= CCL_STAT_QUIT
;
781 code
= XINT (ccl_prog
[ic
]); ic
++;
783 field2
= (code
& 0xFF) >> 5;
786 #define RRR (field1 & 7)
787 #define Rrr ((field1 >> 3) & 7)
789 #define EXCMD (field1 >> 6)
793 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
797 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
801 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
802 reg
[rrr
] = XINT (ccl_prog
[ic
]);
806 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
809 if ((unsigned int) i
< j
)
810 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
814 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
818 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
823 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
829 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
833 CCL_READ_CHAR (reg
[rrr
]);
837 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
838 i
= XINT (ccl_prog
[ic
]);
843 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
844 i
= XINT (ccl_prog
[ic
]);
847 CCL_READ_CHAR (reg
[rrr
]);
851 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
852 j
= XINT (ccl_prog
[ic
]);
854 CCL_WRITE_STRING (j
);
858 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
860 j
= XINT (ccl_prog
[ic
]);
861 if ((unsigned int) i
< j
)
863 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
867 CCL_READ_CHAR (reg
[rrr
]);
868 ic
+= ADDR
- (j
+ 2);
871 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
872 CCL_READ_CHAR (reg
[rrr
]);
876 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
877 CCL_READ_CHAR (reg
[rrr
]);
878 /* fall through ... */
879 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
880 if ((unsigned int) reg
[rrr
] < field1
)
881 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
883 ic
+= XINT (ccl_prog
[ic
+ field1
]);
886 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
889 CCL_READ_CHAR (reg
[rrr
]);
891 code
= XINT (ccl_prog
[ic
]); ic
++;
893 field2
= (code
& 0xFF) >> 5;
897 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
900 j
= XINT (ccl_prog
[ic
]);
905 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
911 code
= XINT (ccl_prog
[ic
]); ic
++;
913 field2
= (code
& 0xFF) >> 5;
917 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
924 case CCL_Call
: /* CCCCCCCCCCCCCCCCCCCC000XXXXX */
930 || field1
>= XVECTOR (Vccl_program_table
)->size
931 || (slot
= XVECTOR (Vccl_program_table
)->contents
[field1
],
933 || !VECTORP (XCONS (slot
)->cdr
))
937 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
938 ic
= ccl_prog_stack_struct
[0].ic
;
943 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
944 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
946 ccl_prog
= XVECTOR (XCONS (slot
)->cdr
)->contents
;
947 ic
= CCL_HEADER_MAIN
;
951 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
953 CCL_WRITE_CHAR (field1
);
956 CCL_WRITE_STRING (field1
);
957 ic
+= (field1
+ 2) / 3;
961 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
963 if ((unsigned int) i
< field1
)
965 j
= XINT (ccl_prog
[ic
+ i
]);
971 case CCL_End
: /* 0000000000000000000000XXXXX */
974 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
975 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
980 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
981 i
= XINT (ccl_prog
[ic
]);
986 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
993 case CCL_PLUS
: reg
[rrr
] += i
; break;
994 case CCL_MINUS
: reg
[rrr
] -= i
; break;
995 case CCL_MUL
: reg
[rrr
] *= i
; break;
996 case CCL_DIV
: reg
[rrr
] /= i
; break;
997 case CCL_MOD
: reg
[rrr
] %= i
; break;
998 case CCL_AND
: reg
[rrr
] &= i
; break;
999 case CCL_OR
: reg
[rrr
] |= i
; break;
1000 case CCL_XOR
: reg
[rrr
] ^= i
; break;
1001 case CCL_LSH
: reg
[rrr
] <<= i
; break;
1002 case CCL_RSH
: reg
[rrr
] >>= i
; break;
1003 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
1004 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
1005 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
1006 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
1007 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
1008 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
1009 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
1010 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
1011 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
1012 default: CCL_INVALID_CMD
;
1016 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1018 j
= XINT (ccl_prog
[ic
]);
1020 jump_address
= ++ic
;
1023 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1030 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1031 CCL_READ_CHAR (reg
[rrr
]);
1032 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1034 op
= XINT (ccl_prog
[ic
]);
1035 jump_address
= ic
++ + ADDR
;
1036 j
= XINT (ccl_prog
[ic
]);
1041 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1042 CCL_READ_CHAR (reg
[rrr
]);
1043 case CCL_JumpCondExprReg
:
1045 op
= XINT (ccl_prog
[ic
]);
1046 jump_address
= ic
++ + ADDR
;
1047 j
= reg
[XINT (ccl_prog
[ic
])];
1054 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1055 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1056 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1057 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1058 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1059 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1060 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1061 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1062 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1063 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1064 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1065 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1066 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1067 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1068 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1069 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1070 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1071 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1072 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1073 case CCL_ENCODE_SJIS
: ENCODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1074 case CCL_DECODE_SJIS
: DECODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1075 default: CCL_INVALID_CMD
;
1078 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1090 case CCL_ReadMultibyteChar2
:
1097 goto ccl_read_multibyte_character_suspend
;
1101 if (i
== LEADING_CODE_COMPOSITION
)
1104 goto ccl_read_multibyte_character_suspend
;
1107 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1111 ccl
->private_state
= COMPOSING_NO_RULE_HEAD
;
1113 if (ccl
->private_state
!= 0)
1115 /* composite character */
1117 ccl
->private_state
= 0;
1123 goto ccl_read_multibyte_character_suspend
;
1129 if (COMPOSING_WITH_RULE_RULE
== ccl
->private_state
)
1131 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1134 else if (COMPOSING_WITH_RULE_HEAD
== ccl
->private_state
)
1135 ccl
->private_state
= COMPOSING_WITH_RULE_RULE
;
1142 reg
[RRR
] = CHARSET_ASCII
;
1144 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION1
)
1147 goto ccl_read_multibyte_character_suspend
;
1149 reg
[rrr
] = (*src
++ & 0x7F);
1151 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION2
)
1153 if ((src
+ 1) >= src_end
)
1154 goto ccl_read_multibyte_character_suspend
;
1156 i
= (*src
++ & 0x7F);
1157 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1160 else if ((i
== LEADING_CODE_PRIVATE_11
)
1161 || (i
== LEADING_CODE_PRIVATE_12
))
1163 if ((src
+ 1) >= src_end
)
1164 goto ccl_read_multibyte_character_suspend
;
1166 reg
[rrr
] = (*src
++ & 0x7F);
1168 else if ((i
== LEADING_CODE_PRIVATE_21
)
1169 || (i
== LEADING_CODE_PRIVATE_22
))
1171 if ((src
+ 2) >= src_end
)
1172 goto ccl_read_multibyte_character_suspend
;
1174 i
= (*src
++ & 0x7F);
1175 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1181 Returned charset is -1. */
1187 ccl_read_multibyte_character_suspend
:
1189 if (ccl
->last_block
)
1195 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC
);
1199 case CCL_WriteMultibyteChar2
:
1200 i
= reg
[RRR
]; /* charset */
1201 if (i
== CHARSET_ASCII
)
1202 i
= reg
[rrr
] & 0x7F;
1203 else if (i
== CHARSET_COMPOSITION
)
1204 i
= MAKE_COMPOSITE_CHAR (reg
[rrr
]);
1205 else if (CHARSET_DIMENSION (i
) == 1)
1206 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1207 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1208 i
= ((i
- 0x8F) << 14) | reg
[rrr
];
1210 i
= ((i
- 0xE0) << 14) | reg
[rrr
];
1216 case CCL_TranslateCharacter
:
1217 i
= reg
[RRR
]; /* charset */
1218 if (i
== CHARSET_ASCII
)
1219 i
= reg
[rrr
] & 0x7F;
1220 else if (i
== CHARSET_COMPOSITION
)
1225 else if (CHARSET_DIMENSION (i
) == 1)
1226 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1227 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1228 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1230 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1232 op
= translate_char (GET_TRANSLATION_TABLE (reg
[Rrr
]),
1234 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1241 case CCL_TranslateCharacterConstTbl
:
1242 op
= XINT (ccl_prog
[ic
]); /* table */
1244 i
= reg
[RRR
]; /* charset */
1245 if (i
== CHARSET_ASCII
)
1246 i
= reg
[rrr
] & 0x7F;
1247 else if (i
== CHARSET_COMPOSITION
)
1252 else if (CHARSET_DIMENSION (i
) == 1)
1253 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1254 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1255 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1257 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1259 op
= translate_char (GET_TRANSLATION_TABLE (op
), i
, -1, 0, 0);
1260 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1267 case CCL_IterateMultipleMap
:
1269 Lisp_Object map
, content
, attrib
, value
;
1270 int point
, size
, fin_ic
;
1272 j
= XINT (ccl_prog
[ic
++]); /* number of maps. */
1275 if ((j
> reg
[RRR
]) && (j
>= 0))
1290 size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1291 point
= XINT (ccl_prog
[ic
++]);
1292 if (point
>= size
) continue;
1294 XVECTOR (Vcode_conversion_map_vector
)->contents
[point
];
1296 /* Check map varidity. */
1297 if (!CONSP (map
)) continue;
1298 map
= XCONS(map
)->cdr
;
1299 if (!VECTORP (map
)) continue;
1300 size
= XVECTOR (map
)->size
;
1301 if (size
<= 1) continue;
1303 content
= XVECTOR (map
)->contents
[0];
1306 [STARTPOINT VAL1 VAL2 ...] or
1307 [t ELELMENT STARTPOINT ENDPOINT] */
1308 if (NUMBERP (content
))
1310 point
= XUINT (content
);
1311 point
= op
- point
+ 1;
1312 if (!((point
>= 1) && (point
< size
))) continue;
1313 content
= XVECTOR (map
)->contents
[point
];
1315 else if (EQ (content
, Qt
))
1317 if (size
!= 4) continue;
1318 if ((op
>= XUINT (XVECTOR (map
)->contents
[2]))
1319 && (op
< XUINT (XVECTOR (map
)->contents
[3])))
1320 content
= XVECTOR (map
)->contents
[1];
1329 else if (NUMBERP (content
))
1332 reg
[rrr
] = XINT(content
);
1335 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1340 else if (CONSP (content
))
1342 attrib
= XCONS (content
)->car
;
1343 value
= XCONS (content
)->cdr
;
1344 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1347 reg
[rrr
] = XUINT (value
);
1357 case CCL_MapMultiple
:
1359 Lisp_Object map
, content
, attrib
, value
;
1360 int point
, size
, map_vector_size
;
1361 int map_set_rest_length
, fin_ic
;
1363 map_set_rest_length
=
1364 XINT (ccl_prog
[ic
++]); /* number of maps and separators. */
1365 fin_ic
= ic
+ map_set_rest_length
;
1366 if ((map_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1370 map_set_rest_length
-= i
;
1378 mapping_stack_pointer
= mapping_stack
;
1380 PUSH_MAPPING_STACK (0, op
);
1382 map_vector_size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1383 for (;map_set_rest_length
> 0;i
++, map_set_rest_length
--)
1385 point
= XINT(ccl_prog
[ic
++]);
1389 if (mapping_stack_pointer
1390 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1394 PUSH_MAPPING_STACK (map_set_rest_length
- point
,
1396 map_set_rest_length
= point
+ 1;
1401 if (point
>= map_vector_size
) continue;
1402 map
= (XVECTOR (Vcode_conversion_map_vector
)
1405 /* Check map varidity. */
1406 if (!CONSP (map
)) continue;
1407 map
= XCONS (map
)->cdr
;
1408 if (!VECTORP (map
)) continue;
1409 size
= XVECTOR (map
)->size
;
1410 if (size
<= 1) continue;
1412 content
= XVECTOR (map
)->contents
[0];
1415 [STARTPOINT VAL1 VAL2 ...] or
1416 [t ELEMENT STARTPOINT ENDPOINT] */
1417 if (NUMBERP (content
))
1419 point
= XUINT (content
);
1420 point
= op
- point
+ 1;
1421 if (!((point
>= 1) && (point
< size
))) continue;
1422 content
= XVECTOR (map
)->contents
[point
];
1424 else if (EQ (content
, Qt
))
1426 if (size
!= 4) continue;
1427 if ((op
>= XUINT (XVECTOR (map
)->contents
[2])) &&
1428 (op
< XUINT (XVECTOR (map
)->contents
[3])))
1429 content
= XVECTOR (map
)->contents
[1];
1438 else if (NUMBERP (content
))
1440 op
= XINT (content
);
1442 i
+= map_set_rest_length
;
1443 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1445 else if (CONSP (content
))
1447 attrib
= XCONS (content
)->car
;
1448 value
= XCONS (content
)->cdr
;
1449 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1453 i
+= map_set_rest_length
;
1454 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1456 else if (EQ (content
, Qt
))
1460 i
+= map_set_rest_length
;
1461 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1463 else if (EQ (content
, Qlambda
))
1477 Lisp_Object map
, attrib
, value
, content
;
1479 j
= XINT (ccl_prog
[ic
++]); /* map_id */
1481 if (j
>= XVECTOR (Vcode_conversion_map_vector
)->size
)
1486 map
= XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1492 map
= XCONS(map
)->cdr
;
1498 size
= XVECTOR (map
)->size
;
1499 point
= XUINT (XVECTOR (map
)->contents
[0]);
1500 point
= op
- point
+ 1;
1503 (!((point
>= 1) && (point
< size
))))
1507 content
= XVECTOR (map
)->contents
[point
];
1510 else if (NUMBERP (content
))
1511 reg
[rrr
] = XINT (content
);
1512 else if (EQ (content
, Qt
))
1514 else if (CONSP (content
))
1516 attrib
= XCONS (content
)->car
;
1517 value
= XCONS (content
)->cdr
;
1518 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1520 reg
[rrr
] = XUINT(value
);
1542 /* We can insert an error message only if DESTINATION is
1543 specified and we still have a room to store the message
1551 switch (ccl
->status
)
1553 case CCL_STAT_INVALID_CMD
:
1554 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1555 code
& 0x1F, code
, ic
);
1558 int i
= ccl_backtrace_idx
- 1;
1561 msglen
= strlen (msg
);
1562 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1564 bcopy (msg
, dst
, msglen
);
1568 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1570 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1571 if (ccl_backtrace_table
[i
] == 0)
1573 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1574 msglen
= strlen (msg
);
1575 if (dst
+ msglen
> (dst_bytes
? dst_end
: src
))
1577 bcopy (msg
, dst
, msglen
);
1586 sprintf(msg
, "\nCCL: Quited.");
1590 sprintf(msg
, "\nCCL: Unknown error type (%d).", ccl
->status
);
1593 msglen
= strlen (msg
);
1594 if (dst
+ msglen
<= (dst_bytes
? dst_end
: src
))
1596 bcopy (msg
, dst
, msglen
);
1603 if (consumed
) *consumed
= src
- source
;
1604 return (dst
? dst
- destination
: 0);
1607 /* Setup fields of the structure pointed by CCL appropriately for the
1608 execution of compiled CCL code in VEC (vector of integer). */
1610 setup_ccl_program (ccl
, vec
)
1611 struct ccl_program
*ccl
;
1616 ccl
->size
= XVECTOR (vec
)->size
;
1617 ccl
->prog
= XVECTOR (vec
)->contents
;
1618 ccl
->ic
= CCL_HEADER_MAIN
;
1619 ccl
->eof_ic
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_EOF
]);
1620 ccl
->buf_magnification
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_BUF_MAG
]);
1621 for (i
= 0; i
< 8; i
++)
1623 ccl
->last_block
= 0;
1624 ccl
->private_state
= 0;
1628 /* Resolve symbols in the specified CCL code (Lisp vector). This
1629 function converts symbols of code conversion maps and character
1630 translation tables embeded in the CCL code into their ID numbers. */
1633 resolve_symbol_ccl_program (ccl
)
1637 Lisp_Object result
, contents
, prop
;
1640 veclen
= XVECTOR (result
)->size
;
1642 /* Set CCL program's table ID */
1643 for (i
= 0; i
< veclen
; i
++)
1645 contents
= XVECTOR (result
)->contents
[i
];
1646 if (SYMBOLP (contents
))
1648 if (EQ(result
, ccl
))
1649 result
= Fcopy_sequence (ccl
);
1651 prop
= Fget (contents
, Qtranslation_table_id
);
1654 XVECTOR (result
)->contents
[i
] = prop
;
1657 prop
= Fget (contents
, Qcode_conversion_map_id
);
1660 XVECTOR (result
)->contents
[i
] = prop
;
1663 prop
= Fget (contents
, Qccl_program_idx
);
1666 XVECTOR (result
)->contents
[i
] = prop
;
1678 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
1679 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1681 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1682 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1683 in this case, the execution is slower).\n\
1684 No I/O commands should appear in CCL-PROGRAM.\n\
1686 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1689 As side effect, each element of REGISTERS holds the value of\n\
1690 corresponding register after the execution.")
1692 Lisp_Object ccl_prog
, reg
;
1694 struct ccl_program ccl
;
1698 if ((SYMBOLP (ccl_prog
)) &&
1699 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1701 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1702 CHECK_LIST (ccl_prog
, 0);
1703 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1704 CHECK_VECTOR (ccl_prog
, 1);
1708 CHECK_VECTOR (ccl_prog
, 1);
1709 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1712 CHECK_VECTOR (reg
, 2);
1713 if (XVECTOR (reg
)->size
!= 8)
1714 error ("Invalid length of vector REGISTERS");
1716 setup_ccl_program (&ccl
, ccl_prog
);
1717 for (i
= 0; i
< 8; i
++)
1718 ccl
.reg
[i
] = (INTEGERP (XVECTOR (reg
)->contents
[i
])
1719 ? XINT (XVECTOR (reg
)->contents
[i
])
1722 ccl_driver (&ccl
, (char *)0, (char *)0, 0, 0, (int *)0);
1724 if (ccl
.status
!= CCL_STAT_SUCCESS
)
1725 error ("Error in CCL program at %dth code", ccl
.ic
);
1727 for (i
= 0; i
< 8; i
++)
1728 XSETINT (XVECTOR (reg
)->contents
[i
], ccl
.reg
[i
]);
1732 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
1734 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
1736 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1737 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1738 in this case, the execution is slower).\n\
1740 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
1742 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
1743 R0..R7 are initial values of corresponding registers,\n\
1744 IC is the instruction counter specifying from where to start the program.\n\
1745 If R0..R7 are nil, they are initialized to 0.\n\
1746 If IC is nil, it is initialized to head of the CCL program.\n\
1748 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
1749 when read buffer is exausted, else, IC is always set to the end of\n\
1750 CCL-PROGRAM on exit.\n\
1752 It returns the contents of write buffer as a string,\n\
1753 and as side effect, STATUS is updated.\n\
1754 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
1755 is a unibyte string. By default it is a multibyte string.")
1756 (ccl_prog
, status
, str
, contin
, unibyte_p
)
1757 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
1760 struct ccl_program ccl
;
1764 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1767 if ((SYMBOLP (ccl_prog
)) &&
1768 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1770 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1771 CHECK_LIST (ccl_prog
, 0);
1772 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1773 CHECK_VECTOR (ccl_prog
, 1);
1777 CHECK_VECTOR (ccl_prog
, 1);
1778 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1781 CHECK_VECTOR (status
, 1);
1782 if (XVECTOR (status
)->size
!= 9)
1783 error ("Invalid length of vector STATUS");
1784 CHECK_STRING (str
, 2);
1785 GCPRO3 (ccl_prog
, status
, str
);
1787 setup_ccl_program (&ccl
, ccl_prog
);
1788 for (i
= 0; i
< 8; i
++)
1790 if (NILP (XVECTOR (status
)->contents
[i
]))
1791 XSETINT (XVECTOR (status
)->contents
[i
], 0);
1792 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1793 ccl
.reg
[i
] = XINT (XVECTOR (status
)->contents
[i
]);
1795 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1797 i
= XFASTINT (XVECTOR (status
)->contents
[8]);
1798 if (ccl
.ic
< i
&& i
< ccl
.size
)
1801 outbufsize
= STRING_BYTES (XSTRING (str
)) * ccl
.buf_magnification
+ 256;
1802 outbuf
= (char *) xmalloc (outbufsize
);
1804 error ("Not enough memory");
1805 ccl
.last_block
= NILP (contin
);
1806 produced
= ccl_driver (&ccl
, XSTRING (str
)->data
, outbuf
,
1807 STRING_BYTES (XSTRING (str
)), outbufsize
, (int *)0);
1808 for (i
= 0; i
< 8; i
++)
1809 XSET (XVECTOR (status
)->contents
[i
], Lisp_Int
, ccl
.reg
[i
]);
1810 XSETINT (XVECTOR (status
)->contents
[8], ccl
.ic
);
1813 if (NILP (unibyte_p
))
1814 val
= make_string (outbuf
, produced
);
1816 val
= make_unibyte_string (outbuf
, produced
);
1819 if (ccl
.status
!= CCL_STAT_SUCCESS
1820 && ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
1821 && ccl
.status
!= CCL_STAT_SUSPEND_BY_DST
)
1822 error ("Error in CCL program at %dth code", ccl
.ic
);
1827 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
1829 "Register CCL program PROGRAM of NAME in `ccl-program-table'.\n\
1830 PROGRAM should be a compiled code of CCL program, or nil.\n\
1831 Return index number of the registered CCL program.")
1833 Lisp_Object name
, ccl_prog
;
1835 int len
= XVECTOR (Vccl_program_table
)->size
;
1838 CHECK_SYMBOL (name
, 0);
1839 if (!NILP (ccl_prog
))
1841 CHECK_VECTOR (ccl_prog
, 1);
1842 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1845 for (i
= 0; i
< len
; i
++)
1847 Lisp_Object slot
= XVECTOR (Vccl_program_table
)->contents
[i
];
1852 if (EQ (name
, XCONS (slot
)->car
))
1854 XCONS (slot
)->cdr
= ccl_prog
;
1855 return make_number (i
);
1861 Lisp_Object new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
1864 for (j
= 0; j
< len
; j
++)
1865 XVECTOR (new_table
)->contents
[j
]
1866 = XVECTOR (Vccl_program_table
)->contents
[j
];
1867 Vccl_program_table
= new_table
;
1870 XVECTOR (Vccl_program_table
)->contents
[i
] = Fcons (name
, ccl_prog
);
1871 Fput (name
, Qccl_program_idx
, make_number (i
));
1872 return make_number (i
);
1875 /* Register code conversion map.
1876 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
1877 The first element is start code point.
1878 The rest elements are mapped numbers.
1879 Symbol t means to map to an original number before mapping.
1880 Symbol nil means that the corresponding element is empty.
1881 Symbol lambda menas to terminate mapping here.
1884 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map
,
1885 Sregister_code_conversion_map
,
1887 "Register SYMBOL as code conversion map MAP.\n\
1888 Return index number of the registered map.")
1890 Lisp_Object symbol
, map
;
1892 int len
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1896 CHECK_SYMBOL (symbol
, 0);
1897 CHECK_VECTOR (map
, 1);
1899 for (i
= 0; i
< len
; i
++)
1901 Lisp_Object slot
= XVECTOR (Vcode_conversion_map_vector
)->contents
[i
];
1906 if (EQ (symbol
, XCONS (slot
)->car
))
1908 index
= make_number (i
);
1909 XCONS (slot
)->cdr
= map
;
1910 Fput (symbol
, Qcode_conversion_map
, map
);
1911 Fput (symbol
, Qcode_conversion_map_id
, index
);
1918 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
1921 for (j
= 0; j
< len
; j
++)
1922 XVECTOR (new_vector
)->contents
[j
]
1923 = XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1924 Vcode_conversion_map_vector
= new_vector
;
1927 index
= make_number (i
);
1928 Fput (symbol
, Qcode_conversion_map
, map
);
1929 Fput (symbol
, Qcode_conversion_map_id
, index
);
1930 XVECTOR (Vcode_conversion_map_vector
)->contents
[i
] = Fcons (symbol
, map
);
1938 staticpro (&Vccl_program_table
);
1939 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
1941 Qccl_program
= intern ("ccl-program");
1942 staticpro (&Qccl_program
);
1944 Qccl_program_idx
= intern ("ccl-program-idx");
1945 staticpro (&Qccl_program_idx
);
1947 Qcode_conversion_map
= intern ("code-conversion-map");
1948 staticpro (&Qcode_conversion_map
);
1950 Qcode_conversion_map_id
= intern ("code-conversion-map-id");
1951 staticpro (&Qcode_conversion_map_id
);
1953 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector
,
1954 "Vector of code conversion maps.");
1955 Vcode_conversion_map_vector
= Fmake_vector (make_number (16), Qnil
);
1957 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
1958 "Alist of fontname patterns vs corresponding CCL program.\n\
1959 Each element looks like (REGEXP . CCL-CODE),\n\
1960 where CCL-CODE is a compiled CCL program.\n\
1961 When a font whose name matches REGEXP is used for displaying a character,\n\
1962 CCL-CODE is executed to calculate the code point in the font\n\
1963 from the charset number and position code(s) of the character which are set\n\
1964 in CCL registers R0, R1, and R2 before the execution.\n\
1965 The code point in the font is set in CCL registers R1 and R2\n\
1966 when the execution terminated.\n\
1967 If the font is single-byte font, the register R2 is not used.");
1968 Vfont_ccl_encoder_alist
= Qnil
;
1970 defsubr (&Sccl_execute
);
1971 defsubr (&Sccl_execute_on_string
);
1972 defsubr (&Sregister_ccl_program
);
1973 defsubr (&Sregister_code_conversion_map
);