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 suppried 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 SEPARATERs)
517 A value of each SEPARATER 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 separators by a SEPARATOR) except the case that lambda is
528 encountered (see below).
530 Each map is a Lisp vector of the following format (a) or (b):
531 (a)......[STARTPOINT VAL1 VAL2 ...]
532 (b)......[t VAL STARTPOINT ENDPOINT],
534 STARTPOINT is an offset to be used for indexing a map,
535 ENDPOINT is a maxmum index number of a map,
536 VAL and VALn is a number, nil, t, or lambda.
538 Valid index range of a map of type (a) is:
539 STARTPOINT <= index < STARTPOINT + map_size - 1
540 Valid index range of a map of type (b) is:
541 STARTPOINT <= index < ENDPOINT
543 If VALn is nil, the map is ignored and mapping proceed to the next
545 In VALn is t, reg[rrr] is reverted to the original value and
546 mapping proceed to the next map.
547 If VALn is lambda, mapping in the current MAP-SET finishes
548 and proceed to the upper level MAP-SET. */
550 #define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
551 1:ExtendedCOMMNDXXXRRRrrrXXXXX
563 #define MAX_MAP_SET_LEVEL 20
571 static tr_stack mapping_stack
[MAX_MAP_SET_LEVEL
];
572 static tr_stack
*mapping_stack_pointer
;
574 #define PUSH_MAPPING_STACK(restlen, orig) \
576 mapping_stack_pointer->rest_length = (restlen); \
577 mapping_stack_pointer->orig_val = (orig); \
578 mapping_stack_pointer++; \
581 #define POP_MAPPING_STACK(restlen, orig) \
583 mapping_stack_pointer--; \
584 (restlen) = mapping_stack_pointer->rest_length; \
585 (orig) = mapping_stack_pointer->orig_val; \
588 #define CCL_MapSingle 0x12 /* Map by single code conversion map
589 1:ExtendedCOMMNDXXXRRRrrrXXXXX
591 ------------------------------
592 Map reg[rrr] by MAP-ID.
593 If some valid mapping is found,
594 set reg[rrr] to the result,
599 /* CCL arithmetic/logical operators. */
600 #define CCL_PLUS 0x00 /* X = Y + Z */
601 #define CCL_MINUS 0x01 /* X = Y - Z */
602 #define CCL_MUL 0x02 /* X = Y * Z */
603 #define CCL_DIV 0x03 /* X = Y / Z */
604 #define CCL_MOD 0x04 /* X = Y % Z */
605 #define CCL_AND 0x05 /* X = Y & Z */
606 #define CCL_OR 0x06 /* X = Y | Z */
607 #define CCL_XOR 0x07 /* X = Y ^ Z */
608 #define CCL_LSH 0x08 /* X = Y << Z */
609 #define CCL_RSH 0x09 /* X = Y >> Z */
610 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
611 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
612 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
613 #define CCL_LS 0x10 /* X = (X < Y) */
614 #define CCL_GT 0x11 /* X = (X > Y) */
615 #define CCL_EQ 0x12 /* X = (X == Y) */
616 #define CCL_LE 0x13 /* X = (X <= Y) */
617 #define CCL_GE 0x14 /* X = (X >= Y) */
618 #define CCL_NE 0x15 /* X = (X != Y) */
620 #define CCL_ENCODE_SJIS 0x16 /* X = HIGHER_BYTE (SJIS (Y, Z))
621 r[7] = LOWER_BYTE (SJIS (Y, Z) */
622 #define CCL_DECODE_SJIS 0x17 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
623 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
625 /* Terminate CCL program successfully. */
626 #define CCL_SUCCESS \
628 ccl->status = CCL_STAT_SUCCESS; \
629 ccl->ic = CCL_HEADER_MAIN; \
633 /* Suspend CCL program because of reading from empty input buffer or
634 writing to full output buffer. When this program is resumed, the
635 same I/O command is executed. */
636 #define CCL_SUSPEND(stat) \
639 ccl->status = stat; \
643 /* Terminate CCL program because of invalid command. Should not occur
644 in the normal case. */
645 #define CCL_INVALID_CMD \
647 ccl->status = CCL_STAT_INVALID_CMD; \
648 goto ccl_error_handler; \
651 /* Encode one character CH to multibyte form and write to the current
652 output buffer. If CH is less than 256, CH is written as is. */
653 #define CCL_WRITE_CHAR(ch) \
659 unsigned char work[4], *str; \
660 int len = CHAR_STRING (ch, work, str); \
661 if (dst + len <= (dst_bytes ? dst_end : src)) \
663 bcopy (str, dst, len); \
667 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
671 /* Write a string at ccl_prog[IC] of length LEN to the current output
673 #define CCL_WRITE_STRING(len) \
677 else if (dst + len <= (dst_bytes ? dst_end : src)) \
678 for (i = 0; i < len; i++) \
679 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
680 >> ((2 - (i % 3)) * 8)) & 0xFF; \
682 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
685 /* Read one byte from the current input buffer into Rth register. */
686 #define CCL_READ_CHAR(r) \
690 else if (src < src_end) \
692 else if (ccl->last_block) \
698 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
702 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
703 text goes to a place pointed by DESTINATION, the length of which
704 should not exceed DST_BYTES. The bytes actually processed is
705 returned as *CONSUMED. The return value is the length of the
706 resulting text. As a side effect, the contents of CCL registers
707 are updated. If SOURCE or DESTINATION is NULL, only operations on
708 registers are permitted. */
711 #define CCL_DEBUG_BACKTRACE_LEN 256
712 int ccl_backtrace_table
[CCL_BACKTRACE_TABLE
];
713 int ccl_backtrace_idx
;
716 struct ccl_prog_stack
718 Lisp_Object
*ccl_prog
; /* Pointer to an array of CCL code. */
719 int ic
; /* Instruction Counter. */
723 ccl_driver (ccl
, source
, destination
, src_bytes
, dst_bytes
, consumed
)
724 struct ccl_program
*ccl
;
725 unsigned char *source
, *destination
;
726 int src_bytes
, dst_bytes
;
729 register int *reg
= ccl
->reg
;
730 register int ic
= ccl
->ic
;
731 register int code
, field1
, field2
;
732 register Lisp_Object
*ccl_prog
= ccl
->prog
;
733 unsigned char *src
= source
, *src_end
= src
+ src_bytes
;
734 unsigned char *dst
= destination
, *dst_end
= dst
+ dst_bytes
;
738 /* For the moment, we only support depth 256 of stack. */
739 struct ccl_prog_stack ccl_prog_stack_struct
[256];
741 if (ic
>= ccl
->eof_ic
)
742 ic
= CCL_HEADER_MAIN
;
745 ccl_backtrace_idx
= 0;
751 ccl_backtrace_table
[ccl_backtrace_idx
++] = ic
;
752 if (ccl_backtrace_idx
>= CCL_DEBUG_BACKTRACE_LEN
)
753 ccl_backtrace_idx
= 0;
754 ccl_backtrace_table
[ccl_backtrace_idx
] = 0;
757 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
759 /* We can't just signal Qquit, instead break the loop as if
760 the whole data is processed. Don't reset Vquit_flag, it
761 must be handled later at a safer place. */
763 src
= source
+ src_bytes
;
764 ccl
->status
= CCL_STAT_QUIT
;
768 code
= XINT (ccl_prog
[ic
]); ic
++;
770 field2
= (code
& 0xFF) >> 5;
773 #define RRR (field1 & 7)
774 #define Rrr ((field1 >> 3) & 7)
776 #define EXCMD (field1 >> 6)
780 case CCL_SetRegister
: /* 00000000000000000RRRrrrXXXXX */
784 case CCL_SetShortConst
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
788 case CCL_SetConst
: /* 00000000000000000000rrrXXXXX */
789 reg
[rrr
] = XINT (ccl_prog
[ic
]);
793 case CCL_SetArray
: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
796 if ((unsigned int) i
< j
)
797 reg
[rrr
] = XINT (ccl_prog
[ic
+ i
]);
801 case CCL_Jump
: /* A--D--D--R--E--S--S-000XXXXX */
805 case CCL_JumpCond
: /* A--D--D--R--E--S--S-rrrXXXXX */
810 case CCL_WriteRegisterJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
816 case CCL_WriteRegisterReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
820 CCL_READ_CHAR (reg
[rrr
]);
824 case CCL_WriteConstJump
: /* A--D--D--R--E--S--S-000XXXXX */
825 i
= XINT (ccl_prog
[ic
]);
830 case CCL_WriteConstReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
831 i
= XINT (ccl_prog
[ic
]);
834 CCL_READ_CHAR (reg
[rrr
]);
838 case CCL_WriteStringJump
: /* A--D--D--R--E--S--S-000XXXXX */
839 j
= XINT (ccl_prog
[ic
]);
841 CCL_WRITE_STRING (j
);
845 case CCL_WriteArrayReadJump
: /* A--D--D--R--E--S--S-rrrXXXXX */
847 j
= XINT (ccl_prog
[ic
]);
848 if ((unsigned int) i
< j
)
850 i
= XINT (ccl_prog
[ic
+ 1 + i
]);
854 CCL_READ_CHAR (reg
[rrr
]);
855 ic
+= ADDR
- (j
+ 2);
858 case CCL_ReadJump
: /* A--D--D--R--E--S--S-rrrYYYYY */
859 CCL_READ_CHAR (reg
[rrr
]);
863 case CCL_ReadBranch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
864 CCL_READ_CHAR (reg
[rrr
]);
865 /* fall through ... */
866 case CCL_Branch
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
867 if ((unsigned int) reg
[rrr
] < field1
)
868 ic
+= XINT (ccl_prog
[ic
+ reg
[rrr
]]);
870 ic
+= XINT (ccl_prog
[ic
+ field1
]);
873 case CCL_ReadRegister
: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
876 CCL_READ_CHAR (reg
[rrr
]);
878 code
= XINT (ccl_prog
[ic
]); ic
++;
880 field2
= (code
& 0xFF) >> 5;
884 case CCL_WriteExprConst
: /* 1:00000OPERATION000RRR000XXXXX */
887 j
= XINT (ccl_prog
[ic
]);
892 case CCL_WriteRegister
: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
898 code
= XINT (ccl_prog
[ic
]); ic
++;
900 field2
= (code
& 0xFF) >> 5;
904 case CCL_WriteExprRegister
: /* 1:00000OPERATIONRrrRRR000XXXXX */
911 case CCL_Call
: /* CCCCCCCCCCCCCCCCCCCC000XXXXX */
917 || field1
>= XVECTOR (Vccl_program_table
)->size
918 || (slot
= XVECTOR (Vccl_program_table
)->contents
[field1
],
920 || !VECTORP (XCONS (slot
)->cdr
))
924 ccl_prog
= ccl_prog_stack_struct
[0].ccl_prog
;
925 ic
= ccl_prog_stack_struct
[0].ic
;
930 ccl_prog_stack_struct
[stack_idx
].ccl_prog
= ccl_prog
;
931 ccl_prog_stack_struct
[stack_idx
].ic
= ic
;
933 ccl_prog
= XVECTOR (XCONS (slot
)->cdr
)->contents
;
934 ic
= CCL_HEADER_MAIN
;
938 case CCL_WriteConstString
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
940 CCL_WRITE_CHAR (field1
);
943 CCL_WRITE_STRING (field1
);
944 ic
+= (field1
+ 2) / 3;
948 case CCL_WriteArray
: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
950 if ((unsigned int) i
< field1
)
952 j
= XINT (ccl_prog
[ic
+ i
]);
958 case CCL_End
: /* 0000000000000000000000XXXXX */
961 ccl_prog
= ccl_prog_stack_struct
[stack_idx
].ccl_prog
;
962 ic
= ccl_prog_stack_struct
[stack_idx
].ic
;
967 case CCL_ExprSelfConst
: /* 00000OPERATION000000rrrXXXXX */
968 i
= XINT (ccl_prog
[ic
]);
973 case CCL_ExprSelfReg
: /* 00000OPERATION000RRRrrrXXXXX */
980 case CCL_PLUS
: reg
[rrr
] += i
; break;
981 case CCL_MINUS
: reg
[rrr
] -= i
; break;
982 case CCL_MUL
: reg
[rrr
] *= i
; break;
983 case CCL_DIV
: reg
[rrr
] /= i
; break;
984 case CCL_MOD
: reg
[rrr
] %= i
; break;
985 case CCL_AND
: reg
[rrr
] &= i
; break;
986 case CCL_OR
: reg
[rrr
] |= i
; break;
987 case CCL_XOR
: reg
[rrr
] ^= i
; break;
988 case CCL_LSH
: reg
[rrr
] <<= i
; break;
989 case CCL_RSH
: reg
[rrr
] >>= i
; break;
990 case CCL_LSH8
: reg
[rrr
] <<= 8; reg
[rrr
] |= i
; break;
991 case CCL_RSH8
: reg
[7] = reg
[rrr
] & 0xFF; reg
[rrr
] >>= 8; break;
992 case CCL_DIVMOD
: reg
[7] = reg
[rrr
] % i
; reg
[rrr
] /= i
; break;
993 case CCL_LS
: reg
[rrr
] = reg
[rrr
] < i
; break;
994 case CCL_GT
: reg
[rrr
] = reg
[rrr
] > i
; break;
995 case CCL_EQ
: reg
[rrr
] = reg
[rrr
] == i
; break;
996 case CCL_LE
: reg
[rrr
] = reg
[rrr
] <= i
; break;
997 case CCL_GE
: reg
[rrr
] = reg
[rrr
] >= i
; break;
998 case CCL_NE
: reg
[rrr
] = reg
[rrr
] != i
; break;
999 default: CCL_INVALID_CMD
;
1003 case CCL_SetExprConst
: /* 00000OPERATION000RRRrrrXXXXX */
1005 j
= XINT (ccl_prog
[ic
]);
1007 jump_address
= ++ic
;
1010 case CCL_SetExprReg
: /* 00000OPERATIONRrrRRRrrrXXXXX */
1017 case CCL_ReadJumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1018 CCL_READ_CHAR (reg
[rrr
]);
1019 case CCL_JumpCondExprConst
: /* A--D--D--R--E--S--S-rrrXXXXX */
1021 op
= XINT (ccl_prog
[ic
]);
1022 jump_address
= ic
++ + ADDR
;
1023 j
= XINT (ccl_prog
[ic
]);
1028 case CCL_ReadJumpCondExprReg
: /* A--D--D--R--E--S--S-rrrXXXXX */
1029 CCL_READ_CHAR (reg
[rrr
]);
1030 case CCL_JumpCondExprReg
:
1032 op
= XINT (ccl_prog
[ic
]);
1033 jump_address
= ic
++ + ADDR
;
1034 j
= reg
[XINT (ccl_prog
[ic
])];
1041 case CCL_PLUS
: reg
[rrr
] = i
+ j
; break;
1042 case CCL_MINUS
: reg
[rrr
] = i
- j
; break;
1043 case CCL_MUL
: reg
[rrr
] = i
* j
; break;
1044 case CCL_DIV
: reg
[rrr
] = i
/ j
; break;
1045 case CCL_MOD
: reg
[rrr
] = i
% j
; break;
1046 case CCL_AND
: reg
[rrr
] = i
& j
; break;
1047 case CCL_OR
: reg
[rrr
] = i
| j
; break;
1048 case CCL_XOR
: reg
[rrr
] = i
^ j
;; break;
1049 case CCL_LSH
: reg
[rrr
] = i
<< j
; break;
1050 case CCL_RSH
: reg
[rrr
] = i
>> j
; break;
1051 case CCL_LSH8
: reg
[rrr
] = (i
<< 8) | j
; break;
1052 case CCL_RSH8
: reg
[rrr
] = i
>> 8; reg
[7] = i
& 0xFF; break;
1053 case CCL_DIVMOD
: reg
[rrr
] = i
/ j
; reg
[7] = i
% j
; break;
1054 case CCL_LS
: reg
[rrr
] = i
< j
; break;
1055 case CCL_GT
: reg
[rrr
] = i
> j
; break;
1056 case CCL_EQ
: reg
[rrr
] = i
== j
; break;
1057 case CCL_LE
: reg
[rrr
] = i
<= j
; break;
1058 case CCL_GE
: reg
[rrr
] = i
>= j
; break;
1059 case CCL_NE
: reg
[rrr
] = i
!= j
; break;
1060 case CCL_ENCODE_SJIS
: ENCODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1061 case CCL_DECODE_SJIS
: DECODE_SJIS (i
, j
, reg
[rrr
], reg
[7]); break;
1062 default: CCL_INVALID_CMD
;
1065 if (code
== CCL_WriteExprConst
|| code
== CCL_WriteExprRegister
)
1077 case CCL_ReadMultibyteChar2
:
1084 goto ccl_read_multibyte_character_suspend
;
1088 if (i
== LEADING_CODE_COMPOSITION
)
1091 goto ccl_read_multibyte_character_suspend
;
1094 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1098 ccl
->private_state
= COMPOSING_NO_RULE_HEAD
;
1100 if (ccl
->private_state
!= 0)
1102 /* composite character */
1104 ccl
->private_state
= 0;
1110 goto ccl_read_multibyte_character_suspend
;
1116 if (COMPOSING_WITH_RULE_RULE
== ccl
->private_state
)
1118 ccl
->private_state
= COMPOSING_WITH_RULE_HEAD
;
1121 else if (COMPOSING_WITH_RULE_HEAD
== ccl
->private_state
)
1122 ccl
->private_state
= COMPOSING_WITH_RULE_RULE
;
1129 reg
[RRR
] = CHARSET_ASCII
;
1131 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION1
)
1134 goto ccl_read_multibyte_character_suspend
;
1136 reg
[rrr
] = (*src
++ & 0x7F);
1138 else if (i
<= MAX_CHARSET_OFFICIAL_DIMENSION2
)
1140 if ((src
+ 1) >= src_end
)
1141 goto ccl_read_multibyte_character_suspend
;
1143 i
= (*src
++ & 0x7F);
1144 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1147 else if ((i
== LEADING_CODE_PRIVATE_11
)
1148 || (i
== LEADING_CODE_PRIVATE_12
))
1150 if ((src
+ 1) >= src_end
)
1151 goto ccl_read_multibyte_character_suspend
;
1153 reg
[rrr
] = (*src
++ & 0x7F);
1155 else if ((i
== LEADING_CODE_PRIVATE_21
)
1156 || (i
== LEADING_CODE_PRIVATE_22
))
1158 if ((src
+ 2) >= src_end
)
1159 goto ccl_read_multibyte_character_suspend
;
1161 i
= (*src
++ & 0x7F);
1162 reg
[rrr
] = ((i
<< 7) | (*src
& 0x7F));
1168 Returned charset is -1. */
1174 ccl_read_multibyte_character_suspend
:
1176 if (ccl
->last_block
)
1182 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC
);
1186 case CCL_WriteMultibyteChar2
:
1187 i
= reg
[RRR
]; /* charset */
1188 if (i
== CHARSET_ASCII
)
1189 i
= reg
[rrr
] & 0x7F;
1190 else if (i
== CHARSET_COMPOSITION
)
1191 i
= MAKE_COMPOSITE_CHAR (reg
[rrr
]);
1192 else if (CHARSET_DIMENSION (i
) == 1)
1193 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1194 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1195 i
= ((i
- 0x8F) << 14) | reg
[rrr
];
1197 i
= ((i
- 0xE0) << 14) | reg
[rrr
];
1203 case CCL_TranslateCharacter
:
1204 i
= reg
[RRR
]; /* charset */
1205 if (i
== CHARSET_ASCII
)
1206 i
= reg
[rrr
] & 0x7F;
1207 else if (i
== CHARSET_COMPOSITION
)
1212 else if (CHARSET_DIMENSION (i
) == 1)
1213 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1214 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1215 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1217 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1219 op
= translate_char (GET_TRANSLATION_TABLE (reg
[Rrr
]),
1221 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1228 case CCL_TranslateCharacterConstTbl
:
1229 op
= XINT (ccl_prog
[ic
]); /* table */
1231 i
= reg
[RRR
]; /* charset */
1232 if (i
== CHARSET_ASCII
)
1233 i
= reg
[rrr
] & 0x7F;
1234 else if (i
== CHARSET_COMPOSITION
)
1239 else if (CHARSET_DIMENSION (i
) == 1)
1240 i
= ((i
- 0x70) << 7) | (reg
[rrr
] & 0x7F);
1241 else if (i
< MIN_CHARSET_PRIVATE_DIMENSION2
)
1242 i
= ((i
- 0x8F) << 14) | (reg
[rrr
] & 0x3FFF);
1244 i
= ((i
- 0xE0) << 14) | (reg
[rrr
] & 0x3FFF);
1246 op
= translate_char (GET_TRANSLATION_TABLE (op
), i
, -1, 0, 0);
1247 SPLIT_CHAR (op
, reg
[RRR
], i
, j
);
1254 case CCL_IterateMultipleMap
:
1256 Lisp_Object map
, content
, attrib
, value
;
1257 int point
, size
, fin_ic
;
1259 j
= XINT (ccl_prog
[ic
++]); /* number of maps. */
1262 if ((j
> reg
[RRR
]) && (j
>= 0))
1277 size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1278 point
= XINT (ccl_prog
[ic
++]);
1279 if (point
>= size
) continue;
1281 XVECTOR (Vcode_conversion_map_vector
)->contents
[point
];
1283 /* Check map varidity. */
1284 if (!CONSP (map
)) continue;
1285 map
= XCONS(map
)->cdr
;
1286 if (!VECTORP (map
)) continue;
1287 size
= XVECTOR (map
)->size
;
1288 if (size
<= 1) continue;
1290 content
= XVECTOR (map
)->contents
[0];
1293 [STARTPOINT VAL1 VAL2 ...] or
1294 [t ELELMENT STARTPOINT ENDPOINT] */
1295 if (NUMBERP (content
))
1297 point
= XUINT (content
);
1298 point
= op
- point
+ 1;
1299 if (!((point
>= 1) && (point
< size
))) continue;
1300 content
= XVECTOR (map
)->contents
[point
];
1302 else if (EQ (content
, Qt
))
1304 if (size
!= 4) continue;
1305 if ((op
>= XUINT (XVECTOR (map
)->contents
[2]))
1306 && (op
< XUINT (XVECTOR (map
)->contents
[3])))
1307 content
= XVECTOR (map
)->contents
[1];
1316 else if (NUMBERP (content
))
1319 reg
[rrr
] = XINT(content
);
1322 else if (EQ (content
, Qt
) || EQ (content
, Qlambda
))
1327 else if (CONSP (content
))
1329 attrib
= XCONS (content
)->car
;
1330 value
= XCONS (content
)->cdr
;
1331 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1334 reg
[rrr
] = XUINT (value
);
1344 case CCL_MapMultiple
:
1346 Lisp_Object map
, content
, attrib
, value
;
1347 int point
, size
, map_vector_size
;
1348 int map_set_rest_length
, fin_ic
;
1350 map_set_rest_length
=
1351 XINT (ccl_prog
[ic
++]); /* number of maps and separators. */
1352 fin_ic
= ic
+ map_set_rest_length
;
1353 if ((map_set_rest_length
> reg
[RRR
]) && (reg
[RRR
] >= 0))
1357 map_set_rest_length
-= i
;
1365 mapping_stack_pointer
= mapping_stack
;
1367 PUSH_MAPPING_STACK (0, op
);
1369 map_vector_size
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1370 for (;map_set_rest_length
> 0;i
++, map_set_rest_length
--)
1372 point
= XINT(ccl_prog
[ic
++]);
1376 if (mapping_stack_pointer
1377 >= &mapping_stack
[MAX_MAP_SET_LEVEL
])
1381 PUSH_MAPPING_STACK (map_set_rest_length
- point
,
1383 map_set_rest_length
= point
+ 1;
1388 if (point
>= map_vector_size
) continue;
1389 map
= (XVECTOR (Vcode_conversion_map_vector
)
1392 /* Check map varidity. */
1393 if (!CONSP (map
)) continue;
1394 map
= XCONS (map
)->cdr
;
1395 if (!VECTORP (map
)) continue;
1396 size
= XVECTOR (map
)->size
;
1397 if (size
<= 1) continue;
1399 content
= XVECTOR (map
)->contents
[0];
1402 [STARTPOINT VAL1 VAL2 ...] or
1403 [t ELEMENT STARTPOINT ENDPOINT] */
1404 if (NUMBERP (content
))
1406 point
= XUINT (content
);
1407 point
= op
- point
+ 1;
1408 if (!((point
>= 1) && (point
< size
))) continue;
1409 content
= XVECTOR (map
)->contents
[point
];
1411 else if (EQ (content
, Qt
))
1413 if (size
!= 4) continue;
1414 if ((op
>= XUINT (XVECTOR (map
)->contents
[2])) &&
1415 (op
< XUINT (XVECTOR (map
)->contents
[3])))
1416 content
= XVECTOR (map
)->contents
[1];
1425 else if (NUMBERP (content
))
1427 op
= XINT (content
);
1429 i
+= map_set_rest_length
;
1430 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1432 else if (CONSP (content
))
1434 attrib
= XCONS (content
)->car
;
1435 value
= XCONS (content
)->cdr
;
1436 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1440 i
+= map_set_rest_length
;
1441 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1443 else if (EQ (content
, Qt
))
1447 i
+= map_set_rest_length
;
1448 POP_MAPPING_STACK (map_set_rest_length
, reg
[rrr
]);
1450 else if (EQ (content
, Qlambda
))
1464 Lisp_Object map
, attrib
, value
, content
;
1466 j
= XINT (ccl_prog
[ic
++]); /* map_id */
1468 if (j
>= XVECTOR (Vcode_conversion_map_vector
)->size
)
1473 map
= XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1479 map
= XCONS(map
)->cdr
;
1485 size
= XVECTOR (map
)->size
;
1486 point
= XUINT (XVECTOR (map
)->contents
[0]);
1487 point
= op
- point
+ 1;
1490 (!((point
>= 1) && (point
< size
))))
1494 content
= XVECTOR (map
)->contents
[point
];
1497 else if (NUMBERP (content
))
1498 reg
[rrr
] = XINT (content
);
1499 else if (EQ (content
, Qt
))
1501 else if (CONSP (content
))
1503 attrib
= XCONS (content
)->car
;
1504 value
= XCONS (content
)->cdr
;
1505 if (!NUMBERP (attrib
) || !NUMBERP (value
))
1507 reg
[rrr
] = XUINT(value
);
1529 /* We can insert an error message only if DESTINATION is
1530 specified and we still have a room to store the message
1535 switch (ccl
->status
)
1537 case CCL_STAT_INVALID_CMD
:
1538 sprintf(msg
, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1539 code
& 0x1F, code
, ic
);
1542 int i
= ccl_backtrace_idx
- 1;
1545 msglen
= strlen (msg
);
1546 if (dst
+ msglen
<= dst_end
)
1548 bcopy (msg
, dst
, msglen
);
1552 for (j
= 0; j
< CCL_DEBUG_BACKTRACE_LEN
; j
++, i
--)
1554 if (i
< 0) i
= CCL_DEBUG_BACKTRACE_LEN
- 1;
1555 if (ccl_backtrace_table
[i
] == 0)
1557 sprintf(msg
, " %d", ccl_backtrace_table
[i
]);
1558 msglen
= strlen (msg
);
1559 if (dst
+ msglen
> dst_end
)
1561 bcopy (msg
, dst
, msglen
);
1569 sprintf(msg
, "\nCCL: Quited.");
1573 sprintf(msg
, "\nCCL: Unknown error type (%d).", ccl
->status
);
1576 msglen
= strlen (msg
);
1577 if (dst
+ msglen
<= dst_end
)
1579 bcopy (msg
, dst
, msglen
);
1586 if (consumed
) *consumed
= src
- source
;
1587 return dst
- destination
;
1590 /* Setup fields of the structure pointed by CCL appropriately for the
1591 execution of compiled CCL code in VEC (vector of integer). */
1593 setup_ccl_program (ccl
, vec
)
1594 struct ccl_program
*ccl
;
1599 ccl
->size
= XVECTOR (vec
)->size
;
1600 ccl
->prog
= XVECTOR (vec
)->contents
;
1601 ccl
->ic
= CCL_HEADER_MAIN
;
1602 ccl
->eof_ic
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_EOF
]);
1603 ccl
->buf_magnification
= XINT (XVECTOR (vec
)->contents
[CCL_HEADER_BUF_MAG
]);
1604 for (i
= 0; i
< 8; i
++)
1606 ccl
->last_block
= 0;
1607 ccl
->private_state
= 0;
1611 /* Resolve symbols in the specified CCL code (Lisp vector). This
1612 function converts symbols of code conversion maps and character
1613 translation tables embeded in the CCL code into their ID numbers. */
1616 resolve_symbol_ccl_program (ccl
)
1620 Lisp_Object result
, contents
, prop
;
1623 veclen
= XVECTOR (result
)->size
;
1625 /* Set CCL program's table ID */
1626 for (i
= 0; i
< veclen
; i
++)
1628 contents
= XVECTOR (result
)->contents
[i
];
1629 if (SYMBOLP (contents
))
1631 if (EQ(result
, ccl
))
1632 result
= Fcopy_sequence (ccl
);
1634 prop
= Fget (contents
, Qtranslation_table_id
);
1637 XVECTOR (result
)->contents
[i
] = prop
;
1640 prop
= Fget (contents
, Qcode_conversion_map_id
);
1643 XVECTOR (result
)->contents
[i
] = prop
;
1646 prop
= Fget (contents
, Qccl_program_idx
);
1649 XVECTOR (result
)->contents
[i
] = prop
;
1661 DEFUN ("ccl-execute", Fccl_execute
, Sccl_execute
, 2, 2, 0,
1662 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1664 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1665 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1666 in this case, the execution is slower).\n\
1667 No I/O commands should appear in CCL-PROGRAM.\n\
1669 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1672 As side effect, each element of REGISTERS holds the value of\n\
1673 corresponding register after the execution.")
1675 Lisp_Object ccl_prog
, reg
;
1677 struct ccl_program ccl
;
1681 if ((SYMBOLP (ccl_prog
)) &&
1682 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1684 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1685 CHECK_LIST (ccl_prog
, 0);
1686 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1687 CHECK_VECTOR (ccl_prog
, 1);
1691 CHECK_VECTOR (ccl_prog
, 1);
1692 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1695 CHECK_VECTOR (reg
, 2);
1696 if (XVECTOR (reg
)->size
!= 8)
1697 error ("Invalid length of vector REGISTERS");
1699 setup_ccl_program (&ccl
, ccl_prog
);
1700 for (i
= 0; i
< 8; i
++)
1701 ccl
.reg
[i
] = (INTEGERP (XVECTOR (reg
)->contents
[i
])
1702 ? XINT (XVECTOR (reg
)->contents
[i
])
1705 ccl_driver (&ccl
, (char *)0, (char *)0, 0, 0, (int *)0);
1707 if (ccl
.status
!= CCL_STAT_SUCCESS
)
1708 error ("Error in CCL program at %dth code", ccl
.ic
);
1710 for (i
= 0; i
< 8; i
++)
1711 XSETINT (XVECTOR (reg
)->contents
[i
], ccl
.reg
[i
]);
1715 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string
, Sccl_execute_on_string
,
1717 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
1719 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1720 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1721 in this case, the execution is slower).\n\
1723 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
1725 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
1726 R0..R7 are initial values of corresponding registers,\n\
1727 IC is the instruction counter specifying from where to start the program.\n\
1728 If R0..R7 are nil, they are initialized to 0.\n\
1729 If IC is nil, it is initialized to head of the CCL program.\n\
1731 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
1732 when read buffer is exausted, else, IC is always set to the end of\n\
1733 CCL-PROGRAM on exit.\n\
1735 It returns the contents of write buffer as a string,\n\
1736 and as side effect, STATUS is updated.\n\
1737 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
1738 is a unibyte string. By default it is a multibyte string.")
1739 (ccl_prog
, status
, str
, contin
, unibyte_p
)
1740 Lisp_Object ccl_prog
, status
, str
, contin
, unibyte_p
;
1743 struct ccl_program ccl
;
1747 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1750 if ((SYMBOLP (ccl_prog
)) &&
1751 (!NILP (ccl_id
= Fget (ccl_prog
, Qccl_program_idx
))))
1753 ccl_prog
= XVECTOR (Vccl_program_table
)->contents
[XUINT (ccl_id
)];
1754 CHECK_LIST (ccl_prog
, 0);
1755 ccl_prog
= XCONS (ccl_prog
)->cdr
;
1756 CHECK_VECTOR (ccl_prog
, 1);
1760 CHECK_VECTOR (ccl_prog
, 1);
1761 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1764 CHECK_VECTOR (status
, 1);
1765 if (XVECTOR (status
)->size
!= 9)
1766 error ("Invalid length of vector STATUS");
1767 CHECK_STRING (str
, 2);
1768 GCPRO3 (ccl_prog
, status
, str
);
1770 setup_ccl_program (&ccl
, ccl_prog
);
1771 for (i
= 0; i
< 8; i
++)
1773 if (NILP (XVECTOR (status
)->contents
[i
]))
1774 XSETINT (XVECTOR (status
)->contents
[i
], 0);
1775 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1776 ccl
.reg
[i
] = XINT (XVECTOR (status
)->contents
[i
]);
1778 if (INTEGERP (XVECTOR (status
)->contents
[i
]))
1780 i
= XFASTINT (XVECTOR (status
)->contents
[8]);
1781 if (ccl
.ic
< i
&& i
< ccl
.size
)
1784 outbufsize
= STRING_BYTES (XSTRING (str
)) * ccl
.buf_magnification
+ 256;
1785 outbuf
= (char *) xmalloc (outbufsize
);
1787 error ("Not enough memory");
1788 ccl
.last_block
= NILP (contin
);
1789 produced
= ccl_driver (&ccl
, XSTRING (str
)->data
, outbuf
,
1790 STRING_BYTES (XSTRING (str
)), outbufsize
, (int *)0);
1791 for (i
= 0; i
< 8; i
++)
1792 XSET (XVECTOR (status
)->contents
[i
], Lisp_Int
, ccl
.reg
[i
]);
1793 XSETINT (XVECTOR (status
)->contents
[8], ccl
.ic
);
1796 if (NILP (unibyte_p
))
1797 val
= make_string (outbuf
, produced
);
1799 val
= make_unibyte_string (outbuf
, produced
);
1802 if (ccl
.status
!= CCL_STAT_SUCCESS
1803 && ccl
.status
!= CCL_STAT_SUSPEND_BY_SRC
1804 && ccl
.status
!= CCL_STAT_SUSPEND_BY_DST
)
1805 error ("Error in CCL program at %dth code", ccl
.ic
);
1810 DEFUN ("register-ccl-program", Fregister_ccl_program
, Sregister_ccl_program
,
1812 "Register CCL program PROGRAM of NAME in `ccl-program-table'.\n\
1813 PROGRAM should be a compiled code of CCL program, or nil.\n\
1814 Return index number of the registered CCL program.")
1816 Lisp_Object name
, ccl_prog
;
1818 int len
= XVECTOR (Vccl_program_table
)->size
;
1821 CHECK_SYMBOL (name
, 0);
1822 if (!NILP (ccl_prog
))
1824 CHECK_VECTOR (ccl_prog
, 1);
1825 ccl_prog
= resolve_symbol_ccl_program (ccl_prog
);
1828 for (i
= 0; i
< len
; i
++)
1830 Lisp_Object slot
= XVECTOR (Vccl_program_table
)->contents
[i
];
1835 if (EQ (name
, XCONS (slot
)->car
))
1837 XCONS (slot
)->cdr
= ccl_prog
;
1838 return make_number (i
);
1844 Lisp_Object new_table
= Fmake_vector (make_number (len
* 2), Qnil
);
1847 for (j
= 0; j
< len
; j
++)
1848 XVECTOR (new_table
)->contents
[j
]
1849 = XVECTOR (Vccl_program_table
)->contents
[j
];
1850 Vccl_program_table
= new_table
;
1853 XVECTOR (Vccl_program_table
)->contents
[i
] = Fcons (name
, ccl_prog
);
1854 Fput (name
, Qccl_program_idx
, make_number (i
));
1855 return make_number (i
);
1858 /* Register code conversion map.
1859 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
1860 The first element is start code point.
1861 The rest elements are mapped numbers.
1862 Symbol t means to map to an original number before mapping.
1863 Symbol nil means that the corresponding element is empty.
1864 Symbol lambda menas to terminate mapping here.
1867 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map
,
1868 Sregister_code_conversion_map
,
1870 "Register SYMBOL as code conversion map MAP.\n\
1871 Return index number of the registered map.")
1873 Lisp_Object symbol
, map
;
1875 int len
= XVECTOR (Vcode_conversion_map_vector
)->size
;
1879 CHECK_SYMBOL (symbol
, 0);
1880 CHECK_VECTOR (map
, 1);
1882 for (i
= 0; i
< len
; i
++)
1884 Lisp_Object slot
= XVECTOR (Vcode_conversion_map_vector
)->contents
[i
];
1889 if (EQ (symbol
, XCONS (slot
)->car
))
1891 index
= make_number (i
);
1892 XCONS (slot
)->cdr
= map
;
1893 Fput (symbol
, Qcode_conversion_map
, map
);
1894 Fput (symbol
, Qcode_conversion_map_id
, index
);
1901 Lisp_Object new_vector
= Fmake_vector (make_number (len
* 2), Qnil
);
1904 for (j
= 0; j
< len
; j
++)
1905 XVECTOR (new_vector
)->contents
[j
]
1906 = XVECTOR (Vcode_conversion_map_vector
)->contents
[j
];
1907 Vcode_conversion_map_vector
= new_vector
;
1910 index
= make_number (i
);
1911 Fput (symbol
, Qcode_conversion_map
, map
);
1912 Fput (symbol
, Qcode_conversion_map_id
, index
);
1913 XVECTOR (Vcode_conversion_map_vector
)->contents
[i
] = Fcons (symbol
, map
);
1921 staticpro (&Vccl_program_table
);
1922 Vccl_program_table
= Fmake_vector (make_number (32), Qnil
);
1924 Qccl_program
= intern ("ccl-program");
1925 staticpro (&Qccl_program
);
1927 Qccl_program_idx
= intern ("ccl-program-idx");
1928 staticpro (&Qccl_program_idx
);
1930 Qcode_conversion_map
= intern ("code-conversion-map");
1931 staticpro (&Qcode_conversion_map
);
1933 Qcode_conversion_map_id
= intern ("code-conversion-map-id");
1934 staticpro (&Qcode_conversion_map_id
);
1936 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector
,
1937 "Vector of code conversion maps.");
1938 Vcode_conversion_map_vector
= Fmake_vector (make_number (16), Qnil
);
1940 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist
,
1941 "Alist of fontname patterns vs corresponding CCL program.\n\
1942 Each element looks like (REGEXP . CCL-CODE),\n\
1943 where CCL-CODE is a compiled CCL program.\n\
1944 When a font whose name matches REGEXP is used for displaying a character,\n\
1945 CCL-CODE is executed to calculate the code point in the font\n\
1946 from the charset number and position code(s) of the character which are set\n\
1947 in CCL registers R0, R1, and R2 before the execution.\n\
1948 The code point in the font is set in CCL registers R1 and R2\n\
1949 when the execution terminated.\n\
1950 If the font is single-byte font, the register R2 is not used.");
1951 Vfont_ccl_encoder_alist
= Qnil
;
1953 defsubr (&Sccl_execute
);
1954 defsubr (&Sccl_execute_on_string
);
1955 defsubr (&Sregister_ccl_program
);
1956 defsubr (&Sregister_code_conversion_map
);