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 character translation table whose ID is
448 A translated character is set in reg[rrr] (code point) and reg[RRR]
451 #define CCL_TranslateCharacter 0x02 /* Translate a multibyte character
452 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
454 /* Translate a character whose code point is reg[rrr] and the charset
455 ID is reg[RRR] by a character translation table whose ID is
458 A translated character is set in reg[rrr] (code point) and reg[RRR]
461 #define CCL_TranslateCharacterConstTbl 0x03 /* Translate a multibyte character
462 1:ExtendedCOMMNDRrrRRRrrrXXXXX
463 2:ARGUMENT(Translation Table ID)
466 /* Iterate looking up MAPs for reg[rrr] starting from the Nth (N =
467 reg[RRR]) MAP until some value is found.
469 Each MAP is a Lisp vector whose element is number, nil, t, or
471 If the element is nil, ignore the map and proceed to the next map.
472 If the element is t or lambda, finish without changing reg[rrr].
473 If the element is a number, set reg[rrr] to the number and finish.
475 Detail of the map structure is descibed in the comment for
476 CCL_MapMultiple below. */
478 #define CCL_IterateMultipleMap 0x10 /* Iterate multiple maps
479 1:ExtendedCOMMNDXXXRRRrrrXXXXX
486 /* Map the code in reg[rrr] by MAPs starting from the Nth (N =
489 MAPs are suppried in the succeeding CCL codes as follows:
491 When CCL program gives this nested structure of map to this command:
494 (MAP-ID121 MAP-ID122 MAP-ID123)
497 (MAP-ID211 (MAP-ID2111) MAP-ID212)
499 the compiled CCL codes has this sequence:
500 CCL_MapMultiple (CCL code of this command)
501 16 (total number of MAPs and SEPARATERs)
519 A value of each SEPARATER follows this rule:
520 MAP-SET := SEPARATOR [(MAP-ID | MAP-SET)]+
521 SEPARATOR := -(number of MAP-IDs and SEPARATORs in the MAP-SET)
523 (*)....Nest level of MAP-SET must not be over than MAX_MAP_SET_LEVEL.
525 When some map fails to map (i.e. it doesn't have a value for
526 reg[rrr]), the mapping is treated as identity.
528 The mapping is iterated for all maps in each map set (set of maps
529 separators by a SEPARATOR) except the case that lambda is
530 encountered (see below).
532 Each map is a Lisp vector of the following format (a) or (b):
533 (a)......[STARTPOINT VAL1 VAL2 ...]
534 (b)......[t VAL STARTPOINT ENDPOINT],
536 STARTPOINT is an offset to be used for indexing a map,
537 ENDPOINT is a maxmum index number of a map,
538 VAL and VALn is a number, nil, t, or lambda.
540 Valid index range of a map of type (a) is:
541 STARTPOINT <= index < STARTPOINT + map_size - 1
542 Valid index range of a map of type (b) is:
543 STARTPOINT <= index < ENDPOINT
545 If VALn is nil, the map is ignored and mapping proceed to the next
547 In VALn is t, reg[rrr] is reverted to the original value and
548 mapping proceed to the next map.
549 If VALn is lambda, mapping in the current MAP-SET finishes
550 and proceed to the upper level MAP-SET. */
552 #define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
553 1:ExtendedCOMMNDXXXRRRrrrXXXXX
565 #define MAX_MAP_SET_LEVEL 20
573 static tr_stack mapping_stack
[MAX_MAP_SET_LEVEL
];
574 static tr_stack
*mapping_stack_pointer
;
576 #define PUSH_MAPPING_STACK(restlen, orig) \
578 mapping_stack_pointer->rest_length = (restlen); \
579 mapping_stack_pointer->orig_val = (orig); \
580 mapping_stack_pointer++; \
583 #define POP_MAPPING_STACK(restlen, orig) \
585 mapping_stack_pointer--; \
586 (restlen) = mapping_stack_pointer->rest_length; \
587 (orig) = mapping_stack_pointer->orig_val; \
590 #define CCL_MapSingle 0x12 /* Map by single code conversion map
591 1:ExtendedCOMMNDXXXRRRrrrXXXXX
593 ------------------------------
594 Map reg[rrr] by MAP-ID.
595 If some valid mapping is found,
596 set reg[rrr] to the result,
601 /* CCL arithmetic/logical operators. */
602 #define CCL_PLUS 0x00 /* X = Y + Z */
603 #define CCL_MINUS 0x01 /* X = Y - Z */
604 #define CCL_MUL 0x02 /* X = Y * Z */
605 #define CCL_DIV 0x03 /* X = Y / Z */
606 #define CCL_MOD 0x04 /* X = Y % Z */
607 #define CCL_AND 0x05 /* X = Y & Z */
608 #define CCL_OR 0x06 /* X = Y | Z */
609 #define CCL_XOR 0x07 /* X = Y ^ Z */
610 #define CCL_LSH 0x08 /* X = Y << Z */
611 #define CCL_RSH 0x09 /* X = Y >> Z */
612 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
613 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
614 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
615 #define CCL_LS 0x10 /* X = (X < Y) */
616 #define CCL_GT 0x11 /* X = (X > Y) */
617 #define CCL_EQ 0x12 /* X = (X == Y) */
618 #define CCL_LE 0x13 /* X = (X <= Y) */
619 #define CCL_GE 0x14 /* X = (X >= Y) */
620 #define CCL_NE 0x15 /* X = (X != Y) */
622 #define CCL_ENCODE_SJIS 0x16 /* X = HIGHER_BYTE (SJIS (Y, Z))
623 r[7] = LOWER_BYTE (SJIS (Y, Z) */
624 #define CCL_DECODE_SJIS 0x17 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
625 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
627 /* Terminate CCL program successfully. */
628 #define CCL_SUCCESS \
630 ccl->status = CCL_STAT_SUCCESS; \
631 ccl->ic = CCL_HEADER_MAIN; \
635 /* Suspend CCL program because of reading from empty input buffer or
636 writing to full output buffer. When this program is resumed, the
637 same I/O command is executed. */
638 #define CCL_SUSPEND(stat) \
641 ccl->status = stat; \
645 /* Terminate CCL program because of invalid command. Should not occur
646 in the normal case. */
647 #define CCL_INVALID_CMD \
649 ccl->status = CCL_STAT_INVALID_CMD; \
650 goto ccl_error_handler; \
653 /* Encode one character CH to multibyte form and write to the current
654 output buffer. If CH is less than 256, CH is written as is. */
655 #define CCL_WRITE_CHAR(ch) \
661 unsigned char work[4], *str; \
662 int len = CHAR_STRING (ch, work, str); \
663 if (dst + len <= (dst_bytes ? dst_end : src)) \
665 bcopy (str, dst, len); \
669 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
673 /* Write a string at ccl_prog[IC] of length LEN to the current output
675 #define CCL_WRITE_STRING(len) \
679 else if (dst + len <= (dst_bytes ? dst_end : src)) \
680 for (i = 0; i < len; i++) \
681 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
682 >> ((2 - (i % 3)) * 8)) & 0xFF; \
684 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
687 /* Read one byte from the current input buffer into Rth register. */
688 #define CCL_READ_CHAR(r) \
692 else if (src < src_end) \
694 else if (ccl->last_block) \
700 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
704 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
705 text goes to a place pointed by DESTINATION, the length of which
706 should not exceed DST_BYTES. The bytes actually processed is
707 returned as *CONSUMED. The return value is the length of the
708 resulting text. As a side effect, the contents of CCL registers
709 are updated. If SOURCE or DESTINATION is NULL, only operations on
710 registers are permitted. */
713 #define CCL_DEBUG_BACKTRACE_LEN 256
714 int ccl_backtrace_table
[CCL_BACKTRACE_TABLE
];
715 int ccl_backtrace_idx
;
718 struct ccl_prog_stack
720 Lisp_Object
*ccl_prog
; /* Pointer to an array of CCL code. */
721 int ic
; /* Instruction Counter. */
725 ccl_driver (ccl
, source
, destination
, src_bytes
, dst_bytes
, consumed
)
726 struct ccl_program
*ccl
;
727 unsigned char *source
, *destination
;
728 int src_bytes
, dst_bytes
;
731 register int *reg
= ccl
->reg
;
732 register int ic
= ccl
->ic
;
733 register int code
, field1
, field2
;
734 register Lisp_Object
*ccl_prog
= ccl
->prog
;
735 unsigned char *src
= source
, *src_end
= src
+ src_bytes
;
736 unsigned char *dst
= destination
, *dst_end
= dst
+ dst_bytes
;
740 /* For the moment, we only support depth 256 of stack. */
741 struct ccl_prog_stack ccl_prog_stack_struct
[256];
743 if (ic
>= ccl
->eof_ic
)
744 ic
= CCL_HEADER_MAIN
;
747 ccl_backtrace_idx
= 0;
753 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
754 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
755 ccl_backtrace_idx
= 0;
756 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
759 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
761 /* We can't just signal Qquit, instead break the loop as if
762 the whole data is processed. Don't reset Vquit_flag, it
763 must be handled later at a safer place. */
765 src
= source
+ src_bytes
;
766 ccl
->status
= CCL_STAT_QUIT
;
770 code
= XINT (ccl_prog
[ic
]); ic
++;
772 field2
= (code
& 0xFF) >> 5;
775 #define RRR (field1 & 7)
776 #define Rrr ((field1 >> 3) & 7)
778 #define EXCMD (field1 >> 6)
782 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
786 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
790 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
791 reg
[rrr
] = XINT (ccl_prog
[ic
]);
795 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
798 if ((unsigned int) i
< j
)
799 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
803 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
807 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
812 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
818 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
822 CCL_READ_CHAR (reg
[rrr
]);
826 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
827 i
= XINT (ccl_prog
[ic
]);
832 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
833 i
= XINT (ccl_prog
[ic
]);
836 CCL_READ_CHAR (reg
[rrr
]);
840 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
841 j
= XINT (ccl_prog
[ic
]);
843 CCL_WRITE_STRING (j
);
847 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
849 j
= XINT (ccl_prog
[ic
]);
850 if ((unsigned int) i
< j
)
852 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
856 CCL_READ_CHAR (reg
[rrr
]);
857 ic
+= ADDR
- (j
+ 2);
860 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
861 CCL_READ_CHAR (reg
[rrr
]);
865 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
866 CCL_READ_CHAR (reg
[rrr
]);
867 /* fall through ... */
868 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
869 if ((unsigned int) reg
[rrr
] < field1
)
870 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
872 ic
+= XINT (ccl_prog
[ic
+ field1
]);
875 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
878 CCL_READ_CHAR (reg
[rrr
]);
880 code
= XINT (ccl_prog
[ic
]); ic
++;
882 field2
= (code
& 0xFF) >> 5;
886 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
889 j
= XINT (ccl_prog
[ic
]);
894 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
900 code
= XINT (ccl_prog
[ic
]); ic
++;
902 field2
= (code
& 0xFF) >> 5;
906 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
913 case CCL_Call
: /* CCCCCCCCCCCCCCCCCCCC000XXXXX */
919 || field1
>= XVECTOR (Vccl_program_table
)->size
920 || (slot
= XVECTOR (Vccl_program_table
)->contents
[field1
],
922 || !VECTORP (XCONS (slot
)->cdr
))
926 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
927 ic
= ccl_prog_stack_struct
[0].ic
;
932 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
933 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
935 ccl_prog
= XVECTOR (XCONS (slot
)->cdr
)->contents
;
936 ic
= CCL_HEADER_MAIN
;
940 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
942 CCL_WRITE_CHAR (field1
);
945 CCL_WRITE_STRING (field1
);
946 ic
+= (field1
+ 2) / 3;
950 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
952 if ((unsigned int) i
< field1
)
954 j
= XINT (ccl_prog
[ic
+ i
]);
960 case CCL_End
: /* 0000000000000000000000XXXXX */
963 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
964 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
969 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
970 i
= XINT (ccl_prog
[ic
]);
975 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
982 case CCL_PLUS
: reg
[rrr
] += i
; break;
983 case CCL_MINUS
: reg
[rrr
] -= i
; break;
984 case CCL_MUL
: reg
[rrr
] *= i
; break;
985 case CCL_DIV
: reg
[rrr
] /= i
; break;
986 case CCL_MOD
: reg
[rrr
] %= i
; break;
987 case CCL_AND
: reg
[rrr
] &= i
; break;
988 case CCL_OR
: reg
[rrr
] |= i
; break;
989 case CCL_XOR
: reg
[rrr
] ^= i
; break;
990 case CCL_LSH
: reg
[rrr
] <<= i
; break;
991 case CCL_RSH
: reg
[rrr
] >>= i
; break;
992 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
993 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
994 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
995 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
996 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
997 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
998 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
999 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
1000 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
1001 default: CCL_INVALID_CMD
;
1005 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1007 j
= XINT (ccl_prog
[ic
]);
1009 jump_address
= ++ic
;
1012 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1019 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1020 CCL_READ_CHAR (reg
[rrr
]);
1021 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1023 op
= XINT (ccl_prog
[ic
]);
1024 jump_address
= ic
++ + ADDR
;
1025 j
= XINT (ccl_prog
[ic
]);
1030 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1031 CCL_READ_CHAR (reg
[rrr
]);
1032 case CCL_JumpCondExprReg
:
1034 op
= XINT (ccl_prog
[ic
]);
1035 jump_address
= ic
++ + ADDR
;
1036 j
= reg
[XINT (ccl_prog
[ic
])];
1043 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1044 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1045 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1046 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1047 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1048 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1049 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1050 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1051 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1052 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1053 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1054 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1055 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1056 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1057 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1058 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1059 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1060 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1061 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1062 case CCL_ENCODE_SJIS
: ENCODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1063 case CCL_DECODE_SJIS
: DECODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1064 default: CCL_INVALID_CMD
;
1067 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1079 case CCL_ReadMultibyteChar2
:
1086 goto ccl_read_multibyte_character_suspend
;
1090 if (i
== LEADING_CODE_COMPOSITION
)
1093 goto ccl_read_multibyte_character_suspend
;
1096 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1100 ccl
->private_state
= COMPOSING_NO_RULE_HEAD
;
1102 if (ccl
->private_state
!= 0)
1104 /* composite character */
1106 ccl
->private_state
= 0;
1112 goto ccl_read_multibyte_character_suspend
;
1118 if (COMPOSING_WITH_RULE_RULE
== ccl
->private_state
)
1120 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1123 else if (COMPOSING_WITH_RULE_HEAD
== ccl
->private_state
)
1124 ccl
->private_state
= COMPOSING_WITH_RULE_RULE
;
1131 reg
[RRR
] = CHARSET_ASCII
;
1133 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION1
)
1136 goto ccl_read_multibyte_character_suspend
;
1138 reg
[rrr
] = (*src
++ & 0x7F);
1140 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION2
)
1142 if ((src
+ 1) >= src_end
)
1143 goto ccl_read_multibyte_character_suspend
;
1145 i
= (*src
++ & 0x7F);
1146 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1149 else if ((i
== LEADING_CODE_PRIVATE_11
)
1150 || (i
== LEADING_CODE_PRIVATE_12
))
1152 if ((src
+ 1) >= src_end
)
1153 goto ccl_read_multibyte_character_suspend
;
1155 reg
[rrr
] = (*src
++ & 0x7F);
1157 else if ((i
== LEADING_CODE_PRIVATE_21
)
1158 || (i
== LEADING_CODE_PRIVATE_22
))
1160 if ((src
+ 2) >= src_end
)
1161 goto ccl_read_multibyte_character_suspend
;
1163 i
= (*src
++ & 0x7F);
1164 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1170 Returned charset is -1. */
1176 ccl_read_multibyte_character_suspend
:
1178 if (ccl
->last_block
)
1184 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC
);
1188 case CCL_WriteMultibyteChar2
:
1189 i
= reg
[RRR
]; /* charset */
1190 if (i
== CHARSET_ASCII
)
1191 i
= reg
[rrr
] & 0x7F;
1192 else if (i
== CHARSET_COMPOSITION
)
1193 i
= MAKE_COMPOSITE_CHAR (reg
[rrr
]);
1194 else if (CHARSET_DIMENSION (i
) == 1)
1195 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1196 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1197 i
= ((i
- 0x8F) << 14) | reg
[rrr
];
1199 i
= ((i
- 0xE0) << 14) | reg
[rrr
];
1205 case CCL_TranslateCharacter
:
1206 i
= reg
[RRR
]; /* charset */
1207 if (i
== CHARSET_ASCII
)
1208 i
= reg
[rrr
] & 0x7F;
1209 else if (i
== CHARSET_COMPOSITION
)
1214 else if (CHARSET_DIMENSION (i
) == 1)
1215 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1216 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1217 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1219 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1221 op
= translate_char (GET_TRANSLATION_TABLE (reg
[Rrr
]),
1223 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1230 case CCL_TranslateCharacterConstTbl
:
1231 op
= XINT (ccl_prog
[ic
]); /* table */
1233 i
= reg
[RRR
]; /* charset */
1234 if (i
== CHARSET_ASCII
)
1235 i
= reg
[rrr
] & 0x7F;
1236 else if (i
== CHARSET_COMPOSITION
)
1241 else if (CHARSET_DIMENSION (i
) == 1)
1242 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1243 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1244 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1246 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1248 op
= translate_char (GET_TRANSLATION_TABLE (op
), i
, -1, 0, 0);
1249 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1256 case CCL_IterateMultipleMap
:
1258 Lisp_Object map
, content
, attrib
, value
;
1259 int point
, size
, fin_ic
;
1261 j
= XINT (ccl_prog
[ic
++]); /* number of maps. */
1264 if ((j
> reg
[RRR
]) && (j
>= 0))
1279 size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1280 point
= XINT (ccl_prog
[ic
++]);
1281 if (point
>= size
) continue;
1283 XVECTOR (Vcode_conversion_map_vector
)->contents
[point
];
1285 /* Check map varidity. */
1286 if (!CONSP (map
)) continue;
1287 map
= XCONS(map
)->cdr
;
1288 if (!VECTORP (map
)) continue;
1289 size
= XVECTOR (map
)->size
;
1290 if (size
<= 1) continue;
1292 content
= XVECTOR (map
)->contents
[0];
1295 [STARTPOINT VAL1 VAL2 ...] or
1296 [t ELELMENT STARTPOINT ENDPOINT] */
1297 if (NUMBERP (content
))
1299 point
= XUINT (content
);
1300 point
= op
- point
+ 1;
1301 if (!((point
>= 1) && (point
< size
))) continue;
1302 content
= XVECTOR (map
)->contents
[point
];
1304 else if (EQ (content
, Qt
))
1306 if (size
!= 4) continue;
1307 if ((op
>= XUINT (XVECTOR (map
)->contents
[2]))
1308 && (op
< XUINT (XVECTOR (map
)->contents
[3])))
1309 content
= XVECTOR (map
)->contents
[1];
1318 else if (NUMBERP (content
))
1321 reg
[rrr
] = XINT(content
);
1324 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1329 else if (CONSP (content
))
1331 attrib
= XCONS (content
)->car
;
1332 value
= XCONS (content
)->cdr
;
1333 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1336 reg
[rrr
] = XUINT (value
);
1346 case CCL_MapMultiple
:
1348 Lisp_Object map
, content
, attrib
, value
;
1349 int point
, size
, map_vector_size
;
1350 int map_set_rest_length
, fin_ic
;
1352 map_set_rest_length
=
1353 XINT (ccl_prog
[ic
++]); /* number of maps and separators. */
1354 fin_ic
= ic
+ map_set_rest_length
;
1355 if ((map_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1359 map_set_rest_length
-= i
;
1367 mapping_stack_pointer
= mapping_stack
;
1369 PUSH_MAPPING_STACK (0, op
);
1371 map_vector_size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1372 for (;map_set_rest_length
> 0;i
++, map_set_rest_length
--)
1374 point
= XINT(ccl_prog
[ic
++]);
1378 if (mapping_stack_pointer
1379 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1383 PUSH_MAPPING_STACK (map_set_rest_length
- point
,
1385 map_set_rest_length
= point
+ 1;
1390 if (point
>= map_vector_size
) continue;
1391 map
= (XVECTOR (Vcode_conversion_map_vector
)
1394 /* Check map varidity. */
1395 if (!CONSP (map
)) continue;
1396 map
= XCONS (map
)->cdr
;
1397 if (!VECTORP (map
)) continue;
1398 size
= XVECTOR (map
)->size
;
1399 if (size
<= 1) continue;
1401 content
= XVECTOR (map
)->contents
[0];
1404 [STARTPOINT VAL1 VAL2 ...] or
1405 [t ELEMENT STARTPOINT ENDPOINT] */
1406 if (NUMBERP (content
))
1408 point
= XUINT (content
);
1409 point
= op
- point
+ 1;
1410 if (!((point
>= 1) && (point
< size
))) continue;
1411 content
= XVECTOR (map
)->contents
[point
];
1413 else if (EQ (content
, Qt
))
1415 if (size
!= 4) continue;
1416 if ((op
>= XUINT (XVECTOR (map
)->contents
[2])) &&
1417 (op
< XUINT (XVECTOR (map
)->contents
[3])))
1418 content
= XVECTOR (map
)->contents
[1];
1427 else if (NUMBERP (content
))
1429 op
= XINT (content
);
1431 i
+= map_set_rest_length
;
1432 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1434 else if (CONSP (content
))
1436 attrib
= XCONS (content
)->car
;
1437 value
= XCONS (content
)->cdr
;
1438 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1442 i
+= map_set_rest_length
;
1443 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1445 else if (EQ (content
, Qt
))
1449 i
+= map_set_rest_length
;
1450 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1452 else if (EQ (content
, Qlambda
))
1466 Lisp_Object map
, attrib
, value
, content
;
1468 j
= XINT (ccl_prog
[ic
++]); /* map_id */
1470 if (j
>= XVECTOR (Vcode_conversion_map_vector
)->size
)
1475 map
= XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1481 map
= XCONS(map
)->cdr
;
1487 size
= XVECTOR (map
)->size
;
1488 point
= XUINT (XVECTOR (map
)->contents
[0]);
1489 point
= op
- point
+ 1;
1492 (!((point
>= 1) && (point
< size
))))
1496 content
= XVECTOR (map
)->contents
[point
];
1499 else if (NUMBERP (content
))
1500 reg
[rrr
] = XINT (content
);
1501 else if (EQ (content
, Qt
))
1503 else if (CONSP (content
))
1505 attrib
= XCONS (content
)->car
;
1506 value
= XCONS (content
)->cdr
;
1507 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1509 reg
[rrr
] = XUINT(value
);
1531 /* We can insert an error message only if DESTINATION is
1532 specified and we still have a room to store the message
1537 switch (ccl
->status
)
1539 case CCL_STAT_INVALID_CMD
:
1540 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1541 code
& 0x1F, code
, ic
);
1544 int i
= ccl_backtrace_idx
- 1;
1547 msglen
= strlen (msg
);
1548 if (dst
+ msglen
<= dst_end
)
1550 bcopy (msg
, dst
, msglen
);
1554 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1556 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1557 if (ccl_backtrace_table
[i
] == 0)
1559 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1560 msglen
= strlen (msg
);
1561 if (dst
+ msglen
> dst_end
)
1563 bcopy (msg
, dst
, msglen
);
1571 sprintf(msg
, "\nCCL: Quited.");
1575 sprintf(msg
, "\nCCL: Unknown error type (%d).", ccl
->status
);
1578 msglen
= strlen (msg
);
1579 if (dst
+ msglen
<= dst_end
)
1581 bcopy (msg
, dst
, msglen
);
1588 if (consumed
) *consumed
= src
- source
;
1589 return dst
- destination
;
1592 /* Setup fields of the structure pointed by CCL appropriately for the
1593 execution of compiled CCL code in VEC (vector of integer). */
1595 setup_ccl_program (ccl
, vec
)
1596 struct ccl_program
*ccl
;
1601 ccl
->size
= XVECTOR (vec
)->size
;
1602 ccl
->prog
= XVECTOR (vec
)->contents
;
1603 ccl
->ic
= CCL_HEADER_MAIN
;
1604 ccl
->eof_ic
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_EOF
]);
1605 ccl
->buf_magnification
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_BUF_MAG
]);
1606 for (i
= 0; i
< 8; i
++)
1608 ccl
->last_block
= 0;
1609 ccl
->private_state
= 0;
1613 /* Resolve symbols in the specified CCL code (Lisp vector). This
1614 function converts symbols of code conversion maps and character
1615 translation tables embeded in the CCL code into their ID numbers. */
1618 resolve_symbol_ccl_program (ccl
)
1622 Lisp_Object result
, contents
, prop
;
1625 veclen
= XVECTOR (result
)->size
;
1627 /* Set CCL program's table ID */
1628 for (i
= 0; i
< veclen
; i
++)
1630 contents
= XVECTOR (result
)->contents
[i
];
1631 if (SYMBOLP (contents
))
1633 if (EQ(result
, ccl
))
1634 result
= Fcopy_sequence (ccl
);
1636 prop
= Fget (contents
, Qcharacter_translation_table_id
);
1639 XVECTOR (result
)->contents
[i
] = prop
;
1642 prop
= Fget (contents
, Qcode_conversion_map_id
);
1645 XVECTOR (result
)->contents
[i
] = prop
;
1648 prop
= Fget (contents
, Qccl_program_idx
);
1651 XVECTOR (result
)->contents
[i
] = prop
;
1663 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
1664 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1666 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1667 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1668 in this case, the execution is slower).\n\
1669 No I/O commands should appear in CCL-PROGRAM.\n\
1671 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1674 As side effect, each element of REGISTERS holds the value of\n\
1675 corresponding register after the execution.")
1677 Lisp_Object ccl_prog
, reg
;
1679 struct ccl_program ccl
;
1683 if ((SYMBOLP (ccl_prog
)) &&
1684 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1686 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1687 CHECK_LIST (ccl_prog
, 0);
1688 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1689 CHECK_VECTOR (ccl_prog
, 1);
1693 CHECK_VECTOR (ccl_prog
, 1);
1694 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1697 CHECK_VECTOR (reg
, 2);
1698 if (XVECTOR (reg
)->size
!= 8)
1699 error ("Invalid length of vector REGISTERS");
1701 setup_ccl_program (&ccl
, ccl_prog
);
1702 for (i
= 0; i
< 8; i
++)
1703 ccl
.reg
[i
] = (INTEGERP (XVECTOR (reg
)->contents
[i
])
1704 ? XINT (XVECTOR (reg
)->contents
[i
])
1707 ccl_driver (&ccl
, (char *)0, (char *)0, 0, 0, (int *)0);
1709 if (ccl
.status
!= CCL_STAT_SUCCESS
)
1710 error ("Error in CCL program at %dth code", ccl
.ic
);
1712 for (i
= 0; i
< 8; i
++)
1713 XSETINT (XVECTOR (reg
)->contents
[i
], ccl
.reg
[i
]);
1717 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
1719 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
1721 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1722 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1723 in this case, the execution is slower).\n\
1725 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
1727 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
1728 R0..R7 are initial values of corresponding registers,\n\
1729 IC is the instruction counter specifying from where to start the program.\n\
1730 If R0..R7 are nil, they are initialized to 0.\n\
1731 If IC is nil, it is initialized to head of the CCL program.\n\
1733 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
1734 when read buffer is exausted, else, IC is always set to the end of\n\
1735 CCL-PROGRAM on exit.\n\
1737 It returns the contents of write buffer as a string,\n\
1738 and as side effect, STATUS is updated.\n\
1739 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
1740 is a unibyte string. By default it is a multibyte string.")
1741 (ccl_prog
, status
, str
, contin
, unibyte_p
)
1742 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
1745 struct ccl_program ccl
;
1749 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1752 if ((SYMBOLP (ccl_prog
)) &&
1753 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1755 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1756 CHECK_LIST (ccl_prog
, 0);
1757 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1758 CHECK_VECTOR (ccl_prog
, 1);
1762 CHECK_VECTOR (ccl_prog
, 1);
1763 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1766 CHECK_VECTOR (status
, 1);
1767 if (XVECTOR (status
)->size
!= 9)
1768 error ("Invalid length of vector STATUS");
1769 CHECK_STRING (str
, 2);
1770 GCPRO3 (ccl_prog
, status
, str
);
1772 setup_ccl_program (&ccl
, ccl_prog
);
1773 for (i
= 0; i
< 8; i
++)
1775 if (NILP (XVECTOR (status
)->contents
[i
]))
1776 XSETINT (XVECTOR (status
)->contents
[i
], 0);
1777 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1778 ccl
.reg
[i
] = XINT (XVECTOR (status
)->contents
[i
]);
1780 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1782 i
= XFASTINT (XVECTOR (status
)->contents
[8]);
1783 if (ccl
.ic
< i
&& i
< ccl
.size
)
1786 outbufsize
= STRING_BYTES (XSTRING (str
)) * ccl
.buf_magnification
+ 256;
1787 outbuf
= (char *) xmalloc (outbufsize
);
1789 error ("Not enough memory");
1790 ccl
.last_block
= NILP (contin
);
1791 produced
= ccl_driver (&ccl
, XSTRING (str
)->data
, outbuf
,
1792 STRING_BYTES (XSTRING (str
)), outbufsize
, (int *)0);
1793 for (i
= 0; i
< 8; i
++)
1794 XSET (XVECTOR (status
)->contents
[i
], Lisp_Int
, ccl
.reg
[i
]);
1795 XSETINT (XVECTOR (status
)->contents
[8], ccl
.ic
);
1798 if (NILP (unibyte_p
))
1799 val
= make_string (outbuf
, produced
);
1801 val
= make_unibyte_string (outbuf
, produced
);
1804 if (ccl
.status
!= CCL_STAT_SUCCESS
1805 && ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
1806 && ccl
.status
!= CCL_STAT_SUSPEND_BY_DST
)
1807 error ("Error in CCL program at %dth code", ccl
.ic
);
1812 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
1814 "Register CCL program PROGRAM of NAME in `ccl-program-table'.\n\
1815 PROGRAM should be a compiled code of CCL program, or nil.\n\
1816 Return index number of the registered CCL program.")
1818 Lisp_Object name
, ccl_prog
;
1820 int len
= XVECTOR (Vccl_program_table
)->size
;
1823 CHECK_SYMBOL (name
, 0);
1824 if (!NILP (ccl_prog
))
1826 CHECK_VECTOR (ccl_prog
, 1);
1827 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1830 for (i
= 0; i
< len
; i
++)
1832 Lisp_Object slot
= XVECTOR (Vccl_program_table
)->contents
[i
];
1837 if (EQ (name
, XCONS (slot
)->car
))
1839 XCONS (slot
)->cdr
= ccl_prog
;
1840 return make_number (i
);
1846 Lisp_Object new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
1849 for (j
= 0; j
< len
; j
++)
1850 XVECTOR (new_table
)->contents
[j
]
1851 = XVECTOR (Vccl_program_table
)->contents
[j
];
1852 Vccl_program_table
= new_table
;
1855 XVECTOR (Vccl_program_table
)->contents
[i
] = Fcons (name
, ccl_prog
);
1856 Fput (name
, Qccl_program_idx
, make_number (i
));
1857 return make_number (i
);
1860 /* Register code conversion map.
1861 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
1862 The first element is start code point.
1863 The rest elements are mapped numbers.
1864 Symbol t means to map to an original number before mapping.
1865 Symbol nil means that the corresponding element is empty.
1866 Symbol lambda menas to terminate mapping here.
1869 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map
,
1870 Sregister_code_conversion_map
,
1872 "Register SYMBOL as code conversion map MAP.\n\
1873 Return index number of the registered map.")
1875 Lisp_Object symbol
, map
;
1877 int len
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1881 CHECK_SYMBOL (symbol
, 0);
1882 CHECK_VECTOR (map
, 1);
1884 for (i
= 0; i
< len
; i
++)
1886 Lisp_Object slot
= XVECTOR (Vcode_conversion_map_vector
)->contents
[i
];
1891 if (EQ (symbol
, XCONS (slot
)->car
))
1893 index
= make_number (i
);
1894 XCONS (slot
)->cdr
= map
;
1895 Fput (symbol
, Qcode_conversion_map
, map
);
1896 Fput (symbol
, Qcode_conversion_map_id
, index
);
1903 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
1906 for (j
= 0; j
< len
; j
++)
1907 XVECTOR (new_vector
)->contents
[j
]
1908 = XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1909 Vcode_conversion_map_vector
= new_vector
;
1912 index
= make_number (i
);
1913 Fput (symbol
, Qcode_conversion_map
, map
);
1914 Fput (symbol
, Qcode_conversion_map_id
, index
);
1915 XVECTOR (Vcode_conversion_map_vector
)->contents
[i
] = Fcons (symbol
, map
);
1923 staticpro (&Vccl_program_table
);
1924 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
1926 Qccl_program
= intern ("ccl-program");
1927 staticpro (&Qccl_program
);
1929 Qccl_program_idx
= intern ("ccl-program-idx");
1930 staticpro (&Qccl_program_idx
);
1932 Qcode_conversion_map
= intern ("code-conversion-map");
1933 staticpro (&Qcode_conversion_map
);
1935 Qcode_conversion_map_id
= intern ("code-conversion-map-id");
1936 staticpro (&Qcode_conversion_map_id
);
1938 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector
,
1939 "Vector of code conversion maps.");
1940 Vcode_conversion_map_vector
= Fmake_vector (make_number (16), Qnil
);
1942 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
1943 "Alist of fontname patterns vs corresponding CCL program.\n\
1944 Each element looks like (REGEXP . CCL-CODE),\n\
1945 where CCL-CODE is a compiled CCL program.\n\
1946 When a font whose name matches REGEXP is used for displaying a character,\n\
1947 CCL-CODE is executed to calculate the code point in the font\n\
1948 from the charset number and position code(s) of the character which are set\n\
1949 in CCL registers R0, R1, and R2 before the execution.\n\
1950 The code point in the font is set in CCL registers R1 and R2\n\
1951 when the execution terminated.\n\
1952 If the font is single-byte font, the register R2 is not used.");
1953 Vfont_ccl_encoder_alist
= Qnil
;
1955 defsubr (&Sccl_execute
);
1956 defsubr (&Sccl_execute_on_string
);
1957 defsubr (&Sregister_ccl_program
);
1958 defsubr (&Sregister_code_conversion_map
);