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 avairable 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 bcopy (str, dst, len); \
677 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
681 /* Write a string at ccl_prog[IC] of length LEN to the current output
683 #define CCL_WRITE_STRING(len) \
687 else if (dst + len <= (dst_bytes ? dst_end : src)) \
688 for (i = 0; i < len; i++) \
689 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
690 >> ((2 - (i % 3)) * 8)) & 0xFF; \
692 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
695 /* Read one byte from the current input buffer into Rth register. */
696 #define CCL_READ_CHAR(r) \
700 else if (src < src_end) \
702 else if (ccl->last_block) \
708 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
712 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
713 text goes to a place pointed by DESTINATION, the length of which
714 should not exceed DST_BYTES. The bytes actually processed is
715 returned as *CONSUMED. The return value is the length of the
716 resulting text. As a side effect, the contents of CCL registers
717 are updated. If SOURCE or DESTINATION is NULL, only operations on
718 registers are permitted. */
721 #define CCL_DEBUG_BACKTRACE_LEN 256
722 int ccl_backtrace_table
[CCL_BACKTRACE_TABLE
];
723 int ccl_backtrace_idx
;
726 struct ccl_prog_stack
728 Lisp_Object
*ccl_prog
; /* Pointer to an array of CCL code. */
729 int ic
; /* Instruction Counter. */
733 ccl_driver (ccl
, source
, destination
, src_bytes
, dst_bytes
, consumed
)
734 struct ccl_program
*ccl
;
735 unsigned char *source
, *destination
;
736 int src_bytes
, dst_bytes
;
739 register int *reg
= ccl
->reg
;
740 register int ic
= ccl
->ic
;
741 register int code
, field1
, field2
;
742 register Lisp_Object
*ccl_prog
= ccl
->prog
;
743 unsigned char *src
= source
, *src_end
= src
+ src_bytes
;
744 unsigned char *dst
= destination
, *dst_end
= dst
+ dst_bytes
;
748 /* For the moment, we only support depth 256 of stack. */
749 struct ccl_prog_stack ccl_prog_stack_struct
[256];
751 if (ic
>= ccl
->eof_ic
)
752 ic
= CCL_HEADER_MAIN
;
755 ccl_backtrace_idx
= 0;
761 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
762 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
763 ccl_backtrace_idx
= 0;
764 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
767 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
769 /* We can't just signal Qquit, instead break the loop as if
770 the whole data is processed. Don't reset Vquit_flag, it
771 must be handled later at a safer place. */
773 src
= source
+ src_bytes
;
774 ccl
->status
= CCL_STAT_QUIT
;
778 code
= XINT (ccl_prog
[ic
]); ic
++;
780 field2
= (code
& 0xFF) >> 5;
783 #define RRR (field1 & 7)
784 #define Rrr ((field1 >> 3) & 7)
786 #define EXCMD (field1 >> 6)
790 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
794 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
798 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
799 reg
[rrr
] = XINT (ccl_prog
[ic
]);
803 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
806 if ((unsigned int) i
< j
)
807 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
811 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
815 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
820 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
826 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
830 CCL_READ_CHAR (reg
[rrr
]);
834 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
835 i
= XINT (ccl_prog
[ic
]);
840 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
841 i
= XINT (ccl_prog
[ic
]);
844 CCL_READ_CHAR (reg
[rrr
]);
848 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
849 j
= XINT (ccl_prog
[ic
]);
851 CCL_WRITE_STRING (j
);
855 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
857 j
= XINT (ccl_prog
[ic
]);
858 if ((unsigned int) i
< j
)
860 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
864 CCL_READ_CHAR (reg
[rrr
]);
865 ic
+= ADDR
- (j
+ 2);
868 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
869 CCL_READ_CHAR (reg
[rrr
]);
873 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
874 CCL_READ_CHAR (reg
[rrr
]);
875 /* fall through ... */
876 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
877 if ((unsigned int) reg
[rrr
] < field1
)
878 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
880 ic
+= XINT (ccl_prog
[ic
+ field1
]);
883 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
886 CCL_READ_CHAR (reg
[rrr
]);
888 code
= XINT (ccl_prog
[ic
]); ic
++;
890 field2
= (code
& 0xFF) >> 5;
894 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
897 j
= XINT (ccl_prog
[ic
]);
902 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
908 code
= XINT (ccl_prog
[ic
]); ic
++;
910 field2
= (code
& 0xFF) >> 5;
914 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
921 case CCL_Call
: /* CCCCCCCCCCCCCCCCCCCC000XXXXX */
927 || field1
>= XVECTOR (Vccl_program_table
)->size
928 || (slot
= XVECTOR (Vccl_program_table
)->contents
[field1
],
930 || !VECTORP (XCONS (slot
)->cdr
))
934 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
935 ic
= ccl_prog_stack_struct
[0].ic
;
940 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
941 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
943 ccl_prog
= XVECTOR (XCONS (slot
)->cdr
)->contents
;
944 ic
= CCL_HEADER_MAIN
;
948 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
950 CCL_WRITE_CHAR (field1
);
953 CCL_WRITE_STRING (field1
);
954 ic
+= (field1
+ 2) / 3;
958 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
960 if ((unsigned int) i
< field1
)
962 j
= XINT (ccl_prog
[ic
+ i
]);
968 case CCL_End
: /* 0000000000000000000000XXXXX */
971 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
972 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
977 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
978 i
= XINT (ccl_prog
[ic
]);
983 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
990 case CCL_PLUS
: reg
[rrr
] += i
; break;
991 case CCL_MINUS
: reg
[rrr
] -= i
; break;
992 case CCL_MUL
: reg
[rrr
] *= i
; break;
993 case CCL_DIV
: reg
[rrr
] /= i
; break;
994 case CCL_MOD
: reg
[rrr
] %= i
; break;
995 case CCL_AND
: reg
[rrr
] &= i
; break;
996 case CCL_OR
: reg
[rrr
] |= i
; break;
997 case CCL_XOR
: reg
[rrr
] ^= i
; break;
998 case CCL_LSH
: reg
[rrr
] <<= i
; break;
999 case CCL_RSH
: reg
[rrr
] >>= i
; break;
1000 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
1001 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
1002 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
1003 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
1004 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
1005 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
1006 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
1007 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
1008 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
1009 default: CCL_INVALID_CMD
;
1013 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1015 j
= XINT (ccl_prog
[ic
]);
1017 jump_address
= ++ic
;
1020 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1027 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1028 CCL_READ_CHAR (reg
[rrr
]);
1029 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1031 op
= XINT (ccl_prog
[ic
]);
1032 jump_address
= ic
++ + ADDR
;
1033 j
= XINT (ccl_prog
[ic
]);
1038 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1039 CCL_READ_CHAR (reg
[rrr
]);
1040 case CCL_JumpCondExprReg
:
1042 op
= XINT (ccl_prog
[ic
]);
1043 jump_address
= ic
++ + ADDR
;
1044 j
= reg
[XINT (ccl_prog
[ic
])];
1051 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1052 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1053 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1054 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1055 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1056 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1057 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1058 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1059 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1060 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1061 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1062 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1063 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1064 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1065 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1066 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1067 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1068 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1069 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1070 case CCL_ENCODE_SJIS
: ENCODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1071 case CCL_DECODE_SJIS
: DECODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1072 default: CCL_INVALID_CMD
;
1075 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1087 case CCL_ReadMultibyteChar2
:
1094 goto ccl_read_multibyte_character_suspend
;
1098 if (i
== LEADING_CODE_COMPOSITION
)
1101 goto ccl_read_multibyte_character_suspend
;
1104 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1108 ccl
->private_state
= COMPOSING_NO_RULE_HEAD
;
1110 if (ccl
->private_state
!= 0)
1112 /* composite character */
1114 ccl
->private_state
= 0;
1120 goto ccl_read_multibyte_character_suspend
;
1126 if (COMPOSING_WITH_RULE_RULE
== ccl
->private_state
)
1128 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1131 else if (COMPOSING_WITH_RULE_HEAD
== ccl
->private_state
)
1132 ccl
->private_state
= COMPOSING_WITH_RULE_RULE
;
1139 reg
[RRR
] = CHARSET_ASCII
;
1141 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION1
)
1144 goto ccl_read_multibyte_character_suspend
;
1146 reg
[rrr
] = (*src
++ & 0x7F);
1148 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION2
)
1150 if ((src
+ 1) >= src_end
)
1151 goto ccl_read_multibyte_character_suspend
;
1153 i
= (*src
++ & 0x7F);
1154 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1157 else if ((i
== LEADING_CODE_PRIVATE_11
)
1158 || (i
== LEADING_CODE_PRIVATE_12
))
1160 if ((src
+ 1) >= src_end
)
1161 goto ccl_read_multibyte_character_suspend
;
1163 reg
[rrr
] = (*src
++ & 0x7F);
1165 else if ((i
== LEADING_CODE_PRIVATE_21
)
1166 || (i
== LEADING_CODE_PRIVATE_22
))
1168 if ((src
+ 2) >= src_end
)
1169 goto ccl_read_multibyte_character_suspend
;
1171 i
= (*src
++ & 0x7F);
1172 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1178 Returned charset is -1. */
1184 ccl_read_multibyte_character_suspend
:
1186 if (ccl
->last_block
)
1192 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC
);
1196 case CCL_WriteMultibyteChar2
:
1197 i
= reg
[RRR
]; /* charset */
1198 if (i
== CHARSET_ASCII
)
1199 i
= reg
[rrr
] & 0x7F;
1200 else if (i
== CHARSET_COMPOSITION
)
1201 i
= MAKE_COMPOSITE_CHAR (reg
[rrr
]);
1202 else if (CHARSET_DIMENSION (i
) == 1)
1203 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1204 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1205 i
= ((i
- 0x8F) << 14) | reg
[rrr
];
1207 i
= ((i
- 0xE0) << 14) | reg
[rrr
];
1213 case CCL_TranslateCharacter
:
1214 i
= reg
[RRR
]; /* charset */
1215 if (i
== CHARSET_ASCII
)
1216 i
= reg
[rrr
] & 0x7F;
1217 else if (i
== CHARSET_COMPOSITION
)
1222 else if (CHARSET_DIMENSION (i
) == 1)
1223 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1224 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1225 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1227 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1229 op
= translate_char (GET_TRANSLATION_TABLE (reg
[Rrr
]),
1231 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1238 case CCL_TranslateCharacterConstTbl
:
1239 op
= XINT (ccl_prog
[ic
]); /* table */
1241 i
= reg
[RRR
]; /* charset */
1242 if (i
== CHARSET_ASCII
)
1243 i
= reg
[rrr
] & 0x7F;
1244 else if (i
== CHARSET_COMPOSITION
)
1249 else if (CHARSET_DIMENSION (i
) == 1)
1250 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1251 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1252 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1254 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1256 op
= translate_char (GET_TRANSLATION_TABLE (op
), i
, -1, 0, 0);
1257 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1264 case CCL_IterateMultipleMap
:
1266 Lisp_Object map
, content
, attrib
, value
;
1267 int point
, size
, fin_ic
;
1269 j
= XINT (ccl_prog
[ic
++]); /* number of maps. */
1272 if ((j
> reg
[RRR
]) && (j
>= 0))
1287 size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1288 point
= XINT (ccl_prog
[ic
++]);
1289 if (point
>= size
) continue;
1291 XVECTOR (Vcode_conversion_map_vector
)->contents
[point
];
1293 /* Check map varidity. */
1294 if (!CONSP (map
)) continue;
1295 map
= XCONS(map
)->cdr
;
1296 if (!VECTORP (map
)) continue;
1297 size
= XVECTOR (map
)->size
;
1298 if (size
<= 1) continue;
1300 content
= XVECTOR (map
)->contents
[0];
1303 [STARTPOINT VAL1 VAL2 ...] or
1304 [t ELELMENT STARTPOINT ENDPOINT] */
1305 if (NUMBERP (content
))
1307 point
= XUINT (content
);
1308 point
= op
- point
+ 1;
1309 if (!((point
>= 1) && (point
< size
))) continue;
1310 content
= XVECTOR (map
)->contents
[point
];
1312 else if (EQ (content
, Qt
))
1314 if (size
!= 4) continue;
1315 if ((op
>= XUINT (XVECTOR (map
)->contents
[2]))
1316 && (op
< XUINT (XVECTOR (map
)->contents
[3])))
1317 content
= XVECTOR (map
)->contents
[1];
1326 else if (NUMBERP (content
))
1329 reg
[rrr
] = XINT(content
);
1332 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1337 else if (CONSP (content
))
1339 attrib
= XCONS (content
)->car
;
1340 value
= XCONS (content
)->cdr
;
1341 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1344 reg
[rrr
] = XUINT (value
);
1354 case CCL_MapMultiple
:
1356 Lisp_Object map
, content
, attrib
, value
;
1357 int point
, size
, map_vector_size
;
1358 int map_set_rest_length
, fin_ic
;
1360 map_set_rest_length
=
1361 XINT (ccl_prog
[ic
++]); /* number of maps and separators. */
1362 fin_ic
= ic
+ map_set_rest_length
;
1363 if ((map_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1367 map_set_rest_length
-= i
;
1375 mapping_stack_pointer
= mapping_stack
;
1377 PUSH_MAPPING_STACK (0, op
);
1379 map_vector_size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1380 for (;map_set_rest_length
> 0;i
++, map_set_rest_length
--)
1382 point
= XINT(ccl_prog
[ic
++]);
1386 if (mapping_stack_pointer
1387 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1391 PUSH_MAPPING_STACK (map_set_rest_length
- point
,
1393 map_set_rest_length
= point
+ 1;
1398 if (point
>= map_vector_size
) continue;
1399 map
= (XVECTOR (Vcode_conversion_map_vector
)
1402 /* Check map varidity. */
1403 if (!CONSP (map
)) continue;
1404 map
= XCONS (map
)->cdr
;
1405 if (!VECTORP (map
)) continue;
1406 size
= XVECTOR (map
)->size
;
1407 if (size
<= 1) continue;
1409 content
= XVECTOR (map
)->contents
[0];
1412 [STARTPOINT VAL1 VAL2 ...] or
1413 [t ELEMENT STARTPOINT ENDPOINT] */
1414 if (NUMBERP (content
))
1416 point
= XUINT (content
);
1417 point
= op
- point
+ 1;
1418 if (!((point
>= 1) && (point
< size
))) continue;
1419 content
= XVECTOR (map
)->contents
[point
];
1421 else if (EQ (content
, Qt
))
1423 if (size
!= 4) continue;
1424 if ((op
>= XUINT (XVECTOR (map
)->contents
[2])) &&
1425 (op
< XUINT (XVECTOR (map
)->contents
[3])))
1426 content
= XVECTOR (map
)->contents
[1];
1435 else if (NUMBERP (content
))
1437 op
= XINT (content
);
1439 i
+= map_set_rest_length
;
1440 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1442 else if (CONSP (content
))
1444 attrib
= XCONS (content
)->car
;
1445 value
= XCONS (content
)->cdr
;
1446 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1450 i
+= map_set_rest_length
;
1451 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1453 else if (EQ (content
, Qt
))
1457 i
+= map_set_rest_length
;
1458 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1460 else if (EQ (content
, Qlambda
))
1474 Lisp_Object map
, attrib
, value
, content
;
1476 j
= XINT (ccl_prog
[ic
++]); /* map_id */
1478 if (j
>= XVECTOR (Vcode_conversion_map_vector
)->size
)
1483 map
= XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1489 map
= XCONS(map
)->cdr
;
1495 size
= XVECTOR (map
)->size
;
1496 point
= XUINT (XVECTOR (map
)->contents
[0]);
1497 point
= op
- point
+ 1;
1500 (!((point
>= 1) && (point
< size
))))
1504 content
= XVECTOR (map
)->contents
[point
];
1507 else if (NUMBERP (content
))
1508 reg
[rrr
] = XINT (content
);
1509 else if (EQ (content
, Qt
))
1511 else if (CONSP (content
))
1513 attrib
= XCONS (content
)->car
;
1514 value
= XCONS (content
)->cdr
;
1515 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1517 reg
[rrr
] = XUINT(value
);
1539 /* We can insert an error message only if DESTINATION is
1540 specified and we still have a room to store the message
1545 switch (ccl
->status
)
1547 case CCL_STAT_INVALID_CMD
:
1548 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1549 code
& 0x1F, code
, ic
);
1552 int i
= ccl_backtrace_idx
- 1;
1555 msglen
= strlen (msg
);
1556 if (dst
+ msglen
<= dst_end
)
1558 bcopy (msg
, dst
, msglen
);
1562 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1564 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1565 if (ccl_backtrace_table
[i
] == 0)
1567 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1568 msglen
= strlen (msg
);
1569 if (dst
+ msglen
> dst_end
)
1571 bcopy (msg
, dst
, msglen
);
1579 sprintf(msg
, "\nCCL: Quited.");
1583 sprintf(msg
, "\nCCL: Unknown error type (%d).", ccl
->status
);
1586 msglen
= strlen (msg
);
1587 if (dst
+ msglen
<= dst_end
)
1589 bcopy (msg
, dst
, msglen
);
1596 if (consumed
) *consumed
= src
- source
;
1597 return dst
- destination
;
1600 /* Setup fields of the structure pointed by CCL appropriately for the
1601 execution of compiled CCL code in VEC (vector of integer). */
1603 setup_ccl_program (ccl
, vec
)
1604 struct ccl_program
*ccl
;
1609 ccl
->size
= XVECTOR (vec
)->size
;
1610 ccl
->prog
= XVECTOR (vec
)->contents
;
1611 ccl
->ic
= CCL_HEADER_MAIN
;
1612 ccl
->eof_ic
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_EOF
]);
1613 ccl
->buf_magnification
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_BUF_MAG
]);
1614 for (i
= 0; i
< 8; i
++)
1616 ccl
->last_block
= 0;
1617 ccl
->private_state
= 0;
1621 /* Resolve symbols in the specified CCL code (Lisp vector). This
1622 function converts symbols of code conversion maps and character
1623 translation tables embeded in the CCL code into their ID numbers. */
1626 resolve_symbol_ccl_program (ccl
)
1630 Lisp_Object result
, contents
, prop
;
1633 veclen
= XVECTOR (result
)->size
;
1635 /* Set CCL program's table ID */
1636 for (i
= 0; i
< veclen
; i
++)
1638 contents
= XVECTOR (result
)->contents
[i
];
1639 if (SYMBOLP (contents
))
1641 if (EQ(result
, ccl
))
1642 result
= Fcopy_sequence (ccl
);
1644 prop
= Fget (contents
, Qtranslation_table_id
);
1647 XVECTOR (result
)->contents
[i
] = prop
;
1650 prop
= Fget (contents
, Qcode_conversion_map_id
);
1653 XVECTOR (result
)->contents
[i
] = prop
;
1656 prop
= Fget (contents
, Qccl_program_idx
);
1659 XVECTOR (result
)->contents
[i
] = prop
;
1671 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
1672 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1674 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1675 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1676 in this case, the execution is slower).\n\
1677 No I/O commands should appear in CCL-PROGRAM.\n\
1679 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1682 As side effect, each element of REGISTERS holds the value of\n\
1683 corresponding register after the execution.")
1685 Lisp_Object ccl_prog
, reg
;
1687 struct ccl_program ccl
;
1691 if ((SYMBOLP (ccl_prog
)) &&
1692 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1694 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1695 CHECK_LIST (ccl_prog
, 0);
1696 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1697 CHECK_VECTOR (ccl_prog
, 1);
1701 CHECK_VECTOR (ccl_prog
, 1);
1702 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1705 CHECK_VECTOR (reg
, 2);
1706 if (XVECTOR (reg
)->size
!= 8)
1707 error ("Invalid length of vector REGISTERS");
1709 setup_ccl_program (&ccl
, ccl_prog
);
1710 for (i
= 0; i
< 8; i
++)
1711 ccl
.reg
[i
] = (INTEGERP (XVECTOR (reg
)->contents
[i
])
1712 ? XINT (XVECTOR (reg
)->contents
[i
])
1715 ccl_driver (&ccl
, (char *)0, (char *)0, 0, 0, (int *)0);
1717 if (ccl
.status
!= CCL_STAT_SUCCESS
)
1718 error ("Error in CCL program at %dth code", ccl
.ic
);
1720 for (i
= 0; i
< 8; i
++)
1721 XSETINT (XVECTOR (reg
)->contents
[i
], ccl
.reg
[i
]);
1725 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
1727 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
1729 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1730 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1731 in this case, the execution is slower).\n\
1733 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
1735 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
1736 R0..R7 are initial values of corresponding registers,\n\
1737 IC is the instruction counter specifying from where to start the program.\n\
1738 If R0..R7 are nil, they are initialized to 0.\n\
1739 If IC is nil, it is initialized to head of the CCL program.\n\
1741 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
1742 when read buffer is exausted, else, IC is always set to the end of\n\
1743 CCL-PROGRAM on exit.\n\
1745 It returns the contents of write buffer as a string,\n\
1746 and as side effect, STATUS is updated.\n\
1747 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
1748 is a unibyte string. By default it is a multibyte string.")
1749 (ccl_prog
, status
, str
, contin
, unibyte_p
)
1750 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
1753 struct ccl_program ccl
;
1757 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1760 if ((SYMBOLP (ccl_prog
)) &&
1761 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1763 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1764 CHECK_LIST (ccl_prog
, 0);
1765 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1766 CHECK_VECTOR (ccl_prog
, 1);
1770 CHECK_VECTOR (ccl_prog
, 1);
1771 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1774 CHECK_VECTOR (status
, 1);
1775 if (XVECTOR (status
)->size
!= 9)
1776 error ("Invalid length of vector STATUS");
1777 CHECK_STRING (str
, 2);
1778 GCPRO3 (ccl_prog
, status
, str
);
1780 setup_ccl_program (&ccl
, ccl_prog
);
1781 for (i
= 0; i
< 8; i
++)
1783 if (NILP (XVECTOR (status
)->contents
[i
]))
1784 XSETINT (XVECTOR (status
)->contents
[i
], 0);
1785 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1786 ccl
.reg
[i
] = XINT (XVECTOR (status
)->contents
[i
]);
1788 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1790 i
= XFASTINT (XVECTOR (status
)->contents
[8]);
1791 if (ccl
.ic
< i
&& i
< ccl
.size
)
1794 outbufsize
= STRING_BYTES (XSTRING (str
)) * ccl
.buf_magnification
+ 256;
1795 outbuf
= (char *) xmalloc (outbufsize
);
1797 error ("Not enough memory");
1798 ccl
.last_block
= NILP (contin
);
1799 produced
= ccl_driver (&ccl
, XSTRING (str
)->data
, outbuf
,
1800 STRING_BYTES (XSTRING (str
)), outbufsize
, (int *)0);
1801 for (i
= 0; i
< 8; i
++)
1802 XSET (XVECTOR (status
)->contents
[i
], Lisp_Int
, ccl
.reg
[i
]);
1803 XSETINT (XVECTOR (status
)->contents
[8], ccl
.ic
);
1806 if (NILP (unibyte_p
))
1807 val
= make_string (outbuf
, produced
);
1809 val
= make_unibyte_string (outbuf
, produced
);
1812 if (ccl
.status
!= CCL_STAT_SUCCESS
1813 && ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
1814 && ccl
.status
!= CCL_STAT_SUSPEND_BY_DST
)
1815 error ("Error in CCL program at %dth code", ccl
.ic
);
1820 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
1822 "Register CCL program PROGRAM of NAME in `ccl-program-table'.\n\
1823 PROGRAM should be a compiled code of CCL program, or nil.\n\
1824 Return index number of the registered CCL program.")
1826 Lisp_Object name
, ccl_prog
;
1828 int len
= XVECTOR (Vccl_program_table
)->size
;
1831 CHECK_SYMBOL (name
, 0);
1832 if (!NILP (ccl_prog
))
1834 CHECK_VECTOR (ccl_prog
, 1);
1835 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1838 for (i
= 0; i
< len
; i
++)
1840 Lisp_Object slot
= XVECTOR (Vccl_program_table
)->contents
[i
];
1845 if (EQ (name
, XCONS (slot
)->car
))
1847 XCONS (slot
)->cdr
= ccl_prog
;
1848 return make_number (i
);
1854 Lisp_Object new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
1857 for (j
= 0; j
< len
; j
++)
1858 XVECTOR (new_table
)->contents
[j
]
1859 = XVECTOR (Vccl_program_table
)->contents
[j
];
1860 Vccl_program_table
= new_table
;
1863 XVECTOR (Vccl_program_table
)->contents
[i
] = Fcons (name
, ccl_prog
);
1864 Fput (name
, Qccl_program_idx
, make_number (i
));
1865 return make_number (i
);
1868 /* Register code conversion map.
1869 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
1870 The first element is start code point.
1871 The rest elements are mapped numbers.
1872 Symbol t means to map to an original number before mapping.
1873 Symbol nil means that the corresponding element is empty.
1874 Symbol lambda menas to terminate mapping here.
1877 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map
,
1878 Sregister_code_conversion_map
,
1880 "Register SYMBOL as code conversion map MAP.\n\
1881 Return index number of the registered map.")
1883 Lisp_Object symbol
, map
;
1885 int len
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1889 CHECK_SYMBOL (symbol
, 0);
1890 CHECK_VECTOR (map
, 1);
1892 for (i
= 0; i
< len
; i
++)
1894 Lisp_Object slot
= XVECTOR (Vcode_conversion_map_vector
)->contents
[i
];
1899 if (EQ (symbol
, XCONS (slot
)->car
))
1901 index
= make_number (i
);
1902 XCONS (slot
)->cdr
= map
;
1903 Fput (symbol
, Qcode_conversion_map
, map
);
1904 Fput (symbol
, Qcode_conversion_map_id
, index
);
1911 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
1914 for (j
= 0; j
< len
; j
++)
1915 XVECTOR (new_vector
)->contents
[j
]
1916 = XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1917 Vcode_conversion_map_vector
= new_vector
;
1920 index
= make_number (i
);
1921 Fput (symbol
, Qcode_conversion_map
, map
);
1922 Fput (symbol
, Qcode_conversion_map_id
, index
);
1923 XVECTOR (Vcode_conversion_map_vector
)->contents
[i
] = Fcons (symbol
, map
);
1931 staticpro (&Vccl_program_table
);
1932 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
1934 Qccl_program
= intern ("ccl-program");
1935 staticpro (&Qccl_program
);
1937 Qccl_program_idx
= intern ("ccl-program-idx");
1938 staticpro (&Qccl_program_idx
);
1940 Qcode_conversion_map
= intern ("code-conversion-map");
1941 staticpro (&Qcode_conversion_map
);
1943 Qcode_conversion_map_id
= intern ("code-conversion-map-id");
1944 staticpro (&Qcode_conversion_map_id
);
1946 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector
,
1947 "Vector of code conversion maps.");
1948 Vcode_conversion_map_vector
= Fmake_vector (make_number (16), Qnil
);
1950 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
1951 "Alist of fontname patterns vs corresponding CCL program.\n\
1952 Each element looks like (REGEXP . CCL-CODE),\n\
1953 where CCL-CODE is a compiled CCL program.\n\
1954 When a font whose name matches REGEXP is used for displaying a character,\n\
1955 CCL-CODE is executed to calculate the code point in the font\n\
1956 from the charset number and position code(s) of the character which are set\n\
1957 in CCL registers R0, R1, and R2 before the execution.\n\
1958 The code point in the font is set in CCL registers R1 and R2\n\
1959 when the execution terminated.\n\
1960 If the font is single-byte font, the register R2 is not used.");
1961 Vfont_ccl_encoder_alist
= Qnil
;
1963 defsubr (&Sccl_execute
);
1964 defsubr (&Sccl_execute_on_string
);
1965 defsubr (&Sregister_ccl_program
);
1966 defsubr (&Sregister_code_conversion_map
);