?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
(erc-button-add-button): Only call `widget-convert-button' in XEmacs.
[emacs.git] / src / ccl.c
blobf110291ac7209a6b4b0edfbe0b874762835ba368
1 /* CCL (Code Conversion Language) interpreter.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005,
3 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
4 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
5 2005, 2006, 2007, 2008, 2009
6 National Institute of Advanced Industrial Science and Technology (AIST)
7 Registration Number H14PRO021
8 Copyright (C) 2003
9 National Institute of Advanced Industrial Science and Technology (AIST)
10 Registration Number H13PRO009
11
12 This file is part of GNU Emacs.
13
14 GNU Emacs is free software: you can redistribute it and/or modify
15 it under the terms of the GNU General Public License as published by
16 the Free Software Foundation, either version 3 of the License, or
17 (at your option) any later version.
18
19 GNU Emacs is distributed in the hope that it will be useful,
20 but WITHOUT ANY WARRANTY; without even the implied warranty of
21 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 GNU General Public License for more details.
23
24 You should have received a copy of the GNU General Public License
25 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
26
27 #include <config.h>
28
29 #include <stdio.h>
30
31 #include "lisp.h"
32 #include "character.h"
33 #include "charset.h"
34 #include "ccl.h"
35 #include "coding.h"
36
37 Lisp_Object Qccl, Qcclp;
38
39 /* This contains all code conversion map available to CCL. */
40 Lisp_Object Vcode_conversion_map_vector;
41
42 /* Alist of fontname patterns vs corresponding CCL program. */
43 Lisp_Object Vfont_ccl_encoder_alist;
44
45 /* This symbol is a property which assocates with ccl program vector.
46 Ex: (get 'ccl-big5-encoder 'ccl-program) returns ccl program vector. */
47 Lisp_Object Qccl_program;
48
49 /* These symbols are properties which associate with code conversion
50 map and their ID respectively. */
51 Lisp_Object Qcode_conversion_map;
52 Lisp_Object Qcode_conversion_map_id;
53
54 /* Symbols of ccl program have this property, a value of the property
55 is an index for Vccl_protram_table. */
56 Lisp_Object Qccl_program_idx;
57
58 /* Table of registered CCL programs. Each element is a vector of
59 NAME, CCL_PROG, RESOLVEDP, and UPDATEDP, where NAME (symbol) is the
60 name of the program, CCL_PROG (vector) is the compiled code of the
61 program, RESOLVEDP (t or nil) is the flag to tell if symbols in
62 CCL_PROG is already resolved to index numbers or not, UPDATEDP (t
63 or nil) is the flat to tell if the CCL program is updated after it
64 was once used. */
65 Lisp_Object Vccl_program_table;
66
67 /* Vector of registered hash tables for translation. */
68 Lisp_Object Vtranslation_hash_table_vector;
69
70 /* Return a hash table of id number ID. */
71 #define GET_HASH_TABLE(id) \
72 (XHASH_TABLE (XCDR(XVECTOR(Vtranslation_hash_table_vector)->contents[(id)])))
73
74 extern int charset_unicode;
75
76 /* CCL (Code Conversion Language) is a simple language which has
77 operations on one input buffer, one output buffer, and 7 registers.
78 The syntax of CCL is described in `ccl.el'. Emacs Lisp function
79 `ccl-compile' compiles a CCL program and produces a CCL code which
80 is a vector of integers. The structure of this vector is as
81 follows: The 1st element: buffer-magnification, a factor for the
82 size of output buffer compared with the size of input buffer. The
83 2nd element: address of CCL code to be executed when encountered
84 with end of input stream. The 3rd and the remaining elements: CCL
85 codes. */
86
87 /* Header of CCL compiled code */
88 #define CCL_HEADER_BUF_MAG 0
89 #define CCL_HEADER_EOF 1
90 #define CCL_HEADER_MAIN 2
91
92 /* CCL code is a sequence of 28-bit non-negative integers (i.e. the
93 MSB is always 0), each contains CCL command and/or arguments in the
94 following format:
95
96 |----------------- integer (28-bit) ------------------|
97 |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
98 |--constant argument--|-register-|-register-|-command-|
99 ccccccccccccccccc RRR rrr XXXXX
100 or
101 |------- relative address -------|-register-|-command-|
102 cccccccccccccccccccc rrr XXXXX
103 or
104 |------------- constant or other args ----------------|
105 cccccccccccccccccccccccccccc
106
107 where, `cc...c' is a non-negative integer indicating constant value
108 (the left most `c' is always 0) or an absolute jump address, `RRR'
109 and `rrr' are CCL register number, `XXXXX' is one of the following
110 CCL commands. */
111
112 /* CCL commands
113
114 Each comment fields shows one or more lines for command syntax and
115 the following lines for semantics of the command. In semantics, IC
116 stands for Instruction Counter. */
117
118 #define CCL_SetRegister 0x00 /* Set register a register value:
119 1:00000000000000000RRRrrrXXXXX
120 ------------------------------
121 reg[rrr] = reg[RRR];
122 */
123
124 #define CCL_SetShortConst 0x01 /* Set register a short constant value:
125 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
126 ------------------------------
127 reg[rrr] = CCCCCCCCCCCCCCCCCCC;
128 */
129
130 #define CCL_SetConst 0x02 /* Set register a constant value:
131 1:00000000000000000000rrrXXXXX
132 2:CONSTANT
133 ------------------------------
134 reg[rrr] = CONSTANT;
135 IC++;
136 */
137
138 #define CCL_SetArray 0x03 /* Set register an element of array:
139 1:CCCCCCCCCCCCCCCCCRRRrrrXXXXX
140 2:ELEMENT[0]
141 3:ELEMENT[1]
142 ...
143 ------------------------------
144 if (0 <= reg[RRR] < CC..C)
145 reg[rrr] = ELEMENT[reg[RRR]];
146 IC += CC..C;
147 */
148
149 #define CCL_Jump 0x04 /* Jump:
150 1:A--D--D--R--E--S--S-000XXXXX
151 ------------------------------
152 IC += ADDRESS;
153 */
154
155 /* Note: If CC..C is greater than 0, the second code is omitted. */
156
157 #define CCL_JumpCond 0x05 /* Jump conditional:
158 1:A--D--D--R--E--S--S-rrrXXXXX
159 ------------------------------
160 if (!reg[rrr])
161 IC += ADDRESS;
162 */
163
164
165 #define CCL_WriteRegisterJump 0x06 /* Write register and jump:
166 1:A--D--D--R--E--S--S-rrrXXXXX
167 ------------------------------
168 write (reg[rrr]);
169 IC += ADDRESS;
170 */
171
172 #define CCL_WriteRegisterReadJump 0x07 /* Write register, read, and jump:
173 1:A--D--D--R--E--S--S-rrrXXXXX
174 2:A--D--D--R--E--S--S-rrrYYYYY
175 -----------------------------
176 write (reg[rrr]);
177 IC++;
178 read (reg[rrr]);
179 IC += ADDRESS;
180 */
181 /* Note: If read is suspended, the resumed execution starts from the
182 second code (YYYYY == CCL_ReadJump). */
183
184 #define CCL_WriteConstJump 0x08 /* Write constant and jump:
185 1:A--D--D--R--E--S--S-000XXXXX
186 2:CONST
187 ------------------------------
188 write (CONST);
189 IC += ADDRESS;
190 */
191
192 #define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump:
193 1:A--D--D--R--E--S--S-rrrXXXXX
194 2:CONST
195 3:A--D--D--R--E--S--S-rrrYYYYY
196 -----------------------------
197 write (CONST);
198 IC += 2;
199 read (reg[rrr]);
200 IC += ADDRESS;
201 */
202 /* Note: If read is suspended, the resumed execution starts from the
203 second code (YYYYY == CCL_ReadJump). */
204
205 #define CCL_WriteStringJump 0x0A /* Write string and jump:
206 1:A--D--D--R--E--S--S-000XXXXX
207 2:LENGTH
208 3:000MSTRIN[0]STRIN[1]STRIN[2]
209 ...
210 ------------------------------
211 if (M)
212 write_multibyte_string (STRING, LENGTH);
213 else
214 write_string (STRING, LENGTH);
215 IC += ADDRESS;
216 */
217
218 #define CCL_WriteArrayReadJump 0x0B /* Write an array element, read, and jump:
219 1:A--D--D--R--E--S--S-rrrXXXXX
220 2:LENGTH
221 3:ELEMENET[0]
222 4:ELEMENET[1]
223 ...
224 N:A--D--D--R--E--S--S-rrrYYYYY
225 ------------------------------
226 if (0 <= reg[rrr] < LENGTH)
227 write (ELEMENT[reg[rrr]]);
228 IC += LENGTH + 2; (... pointing at N+1)
229 read (reg[rrr]);
230 IC += ADDRESS;
231 */
232 /* Note: If read is suspended, the resumed execution starts from the
233 Nth code (YYYYY == CCL_ReadJump). */
234
235 #define CCL_ReadJump 0x0C /* Read and jump:
236 1:A--D--D--R--E--S--S-rrrYYYYY
237 -----------------------------
238 read (reg[rrr]);
239 IC += ADDRESS;
240 */
241
242 #define CCL_Branch 0x0D /* Jump by branch table:
243 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
244 2:A--D--D--R--E-S-S[0]000XXXXX
245 3:A--D--D--R--E-S-S[1]000XXXXX
246 ...
247 ------------------------------
248 if (0 <= reg[rrr] < CC..C)
249 IC += ADDRESS[reg[rrr]];
250 else
251 IC += ADDRESS[CC..C];
252 */
253
254 #define CCL_ReadRegister 0x0E /* Read bytes into registers:
255 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
256 2:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
257 ...
258 ------------------------------
259 while (CCC--)
260 read (reg[rrr]);
261 */
262
263 #define CCL_WriteExprConst 0x0F /* write result of expression:
264 1:00000OPERATION000RRR000XXXXX
265 2:CONSTANT
266 ------------------------------
267 write (reg[RRR] OPERATION CONSTANT);
268 IC++;
269 */
270
271 /* Note: If the Nth read is suspended, the resumed execution starts
272 from the Nth code. */
273
274 #define CCL_ReadBranch 0x10 /* Read one byte into a register,
275 and jump by branch table:
276 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
277 2:A--D--D--R--E-S-S[0]000XXXXX
278 3:A--D--D--R--E-S-S[1]000XXXXX
279 ...
280 ------------------------------
281 read (read[rrr]);
282 if (0 <= reg[rrr] < CC..C)
283 IC += ADDRESS[reg[rrr]];
284 else
285 IC += ADDRESS[CC..C];
286 */
287
288 #define CCL_WriteRegister 0x11 /* Write registers:
289 1:CCCCCCCCCCCCCCCCCCCrrrXXXXX
290 2:CCCCCCCCCCCCCCCCCCCrrrXXXXX
291 ...
292 ------------------------------
293 while (CCC--)
294 write (reg[rrr]);
295 ...
296 */
297
298 /* Note: If the Nth write is suspended, the resumed execution
299 starts from the Nth code. */
300
301 #define CCL_WriteExprRegister 0x12 /* Write result of expression
302 1:00000OPERATIONRrrRRR000XXXXX
303 ------------------------------
304 write (reg[RRR] OPERATION reg[Rrr]);
305 */
306
307 #define CCL_Call 0x13 /* Call the CCL program whose ID is
308 CC..C or cc..c.
309 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX
310 [2:00000000cccccccccccccccccccc]
311 ------------------------------
312 if (FFF)
313 call (cc..c)
314 IC++;
315 else
316 call (CC..C)
317 */
318
319 #define CCL_WriteConstString 0x14 /* Write a constant or a string:
320 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
321 [2:000MSTRIN[0]STRIN[1]STRIN[2]]
322 [...]
323 -----------------------------
324 if (!rrr)
325 write (CC..C)
326 else
327 if (M)
328 write_multibyte_string (STRING, CC..C);
329 else
330 write_string (STRING, CC..C);
331 IC += (CC..C + 2) / 3;
332 */
333
334 #define CCL_WriteArray 0x15 /* Write an element of array:
335 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
336 2:ELEMENT[0]
337 3:ELEMENT[1]
338 ...
339 ------------------------------
340 if (0 <= reg[rrr] < CC..C)
341 write (ELEMENT[reg[rrr]]);
342 IC += CC..C;
343 */
344
345 #define CCL_End 0x16 /* Terminate:
346 1:00000000000000000000000XXXXX
347 ------------------------------
348 terminate ();
349 */
350
351 /* The following two codes execute an assignment arithmetic/logical
352 operation. The form of the operation is like REG OP= OPERAND. */
353
354 #define CCL_ExprSelfConst 0x17 /* REG OP= constant:
355 1:00000OPERATION000000rrrXXXXX
356 2:CONSTANT
357 ------------------------------
358 reg[rrr] OPERATION= CONSTANT;
359 */
360
361 #define CCL_ExprSelfReg 0x18 /* REG1 OP= REG2:
362 1:00000OPERATION000RRRrrrXXXXX
363 ------------------------------
364 reg[rrr] OPERATION= reg[RRR];
365 */
366
367 /* The following codes execute an arithmetic/logical operation. The
368 form of the operation is like REG_X = REG_Y OP OPERAND2. */
369
370 #define CCL_SetExprConst 0x19 /* REG_X = REG_Y OP constant:
371 1:00000OPERATION000RRRrrrXXXXX
372 2:CONSTANT
373 ------------------------------
374 reg[rrr] = reg[RRR] OPERATION CONSTANT;
375 IC++;
376 */
377
378 #define CCL_SetExprReg 0x1A /* REG1 = REG2 OP REG3:
379 1:00000OPERATIONRrrRRRrrrXXXXX
380 ------------------------------
381 reg[rrr] = reg[RRR] OPERATION reg[Rrr];
382 */
383
384 #define CCL_JumpCondExprConst 0x1B /* Jump conditional according to
385 an operation on constant:
386 1:A--D--D--R--E--S--S-rrrXXXXX
387 2:OPERATION
388 3:CONSTANT
389 -----------------------------
390 reg[7] = reg[rrr] OPERATION CONSTANT;
391 if (!(reg[7]))
392 IC += ADDRESS;
393 else
394 IC += 2
395 */
396
397 #define CCL_JumpCondExprReg 0x1C /* Jump conditional according to
398 an operation on register:
399 1:A--D--D--R--E--S--S-rrrXXXXX
400 2:OPERATION
401 3:RRR
402 -----------------------------
403 reg[7] = reg[rrr] OPERATION reg[RRR];
404 if (!reg[7])
405 IC += ADDRESS;
406 else
407 IC += 2;
408 */
409
410 #define CCL_ReadJumpCondExprConst 0x1D /* Read and jump conditional according
411 to an operation on constant:
412 1:A--D--D--R--E--S--S-rrrXXXXX
413 2:OPERATION
414 3:CONSTANT
415 -----------------------------
416 read (reg[rrr]);
417 reg[7] = reg[rrr] OPERATION CONSTANT;
418 if (!reg[7])
419 IC += ADDRESS;
420 else
421 IC += 2;
422 */
423
424 #define CCL_ReadJumpCondExprReg 0x1E /* Read and jump conditional according
425 to an operation on register:
426 1:A--D--D--R--E--S--S-rrrXXXXX
427 2:OPERATION
428 3:RRR
429 -----------------------------
430 read (reg[rrr]);
431 reg[7] = reg[rrr] OPERATION reg[RRR];
432 if (!reg[7])
433 IC += ADDRESS;
434 else
435 IC += 2;
436 */
437
438 #define CCL_Extension 0x1F /* Extended CCL code
439 1:ExtendedCOMMNDRrrRRRrrrXXXXX
440 2:ARGUEMENT
441 3:...
442 ------------------------------
443 extended_command (rrr,RRR,Rrr,ARGS)
444 */
445
446 /*
447 Here after, Extended CCL Instructions.
448 Bit length of extended command is 14.
449 Therefore, the instruction code range is 0..16384(0x3fff).
450 */
451
452 /* Read a multibyte characeter.
453 A code point is stored into reg[rrr]. A charset ID is stored into
454 reg[RRR]. */
455
456 #define CCL_ReadMultibyteChar2 0x00 /* Read Multibyte Character
457 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
458
459 /* Write a multibyte character.
460 Write a character whose code point is reg[rrr] and the charset ID
461 is reg[RRR]. */
462
463 #define CCL_WriteMultibyteChar2 0x01 /* Write Multibyte Character
464 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
465
466 /* Translate a character whose code point is reg[rrr] and the charset
467 ID is reg[RRR] by a translation table whose ID is reg[Rrr].
468
469 A translated character is set in reg[rrr] (code point) and reg[RRR]
470 (charset ID). */
471
472 #define CCL_TranslateCharacter 0x02 /* Translate a multibyte character
473 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
474
475 /* Translate a character whose code point is reg[rrr] and the charset
476 ID is reg[RRR] by a translation table whose ID is ARGUMENT.
477
478 A translated character is set in reg[rrr] (code point) and reg[RRR]
479 (charset ID). */
480
481 #define CCL_TranslateCharacterConstTbl 0x03 /* Translate a multibyte character
482 1:ExtendedCOMMNDRrrRRRrrrXXXXX
483 2:ARGUMENT(Translation Table ID)
484 */
485
486 /* Iterate looking up MAPs for reg[rrr] starting from the Nth (N =
487 reg[RRR]) MAP until some value is found.
488
489 Each MAP is a Lisp vector whose element is number, nil, t, or
490 lambda.
491 If the element is nil, ignore the map and proceed to the next map.
492 If the element is t or lambda, finish without changing reg[rrr].
493 If the element is a number, set reg[rrr] to the number and finish.
494
495 Detail of the map structure is descibed in the comment for
496 CCL_MapMultiple below. */
497
498 #define CCL_IterateMultipleMap 0x10 /* Iterate multiple maps
499 1:ExtendedCOMMNDXXXRRRrrrXXXXX
500 2:NUMBER of MAPs
501 3:MAP-ID1
502 4:MAP-ID2
503 ...
504 */
505
506 /* Map the code in reg[rrr] by MAPs starting from the Nth (N =
507 reg[RRR]) map.
508
509 MAPs are supplied in the succeeding CCL codes as follows:
510
511 When CCL program gives this nested structure of map to this command:
512 ((MAP-ID11
513 MAP-ID12
514 (MAP-ID121 MAP-ID122 MAP-ID123)
515 MAP-ID13)
516 (MAP-ID21
517 (MAP-ID211 (MAP-ID2111) MAP-ID212)
518 MAP-ID22)),
519 the compiled CCL codes has this sequence:
520 CCL_MapMultiple (CCL code of this command)
521 16 (total number of MAPs and SEPARATORs)
522 -7 (1st SEPARATOR)
523 MAP-ID11
524 MAP-ID12
525 -3 (2nd SEPARATOR)
526 MAP-ID121
527 MAP-ID122
528 MAP-ID123
529 MAP-ID13
530 -7 (3rd SEPARATOR)
531 MAP-ID21
532 -4 (4th SEPARATOR)
533 MAP-ID211
534 -1 (5th SEPARATOR)
535 MAP_ID2111
536 MAP-ID212
537 MAP-ID22
538
539 A value of each SEPARATOR follows this rule:
540 MAP-SET := SEPARATOR [(MAP-ID | MAP-SET)]+
541 SEPARATOR := -(number of MAP-IDs and SEPARATORs in the MAP-SET)
542
543 (*)....Nest level of MAP-SET must not be over than MAX_MAP_SET_LEVEL.
544
545 When some map fails to map (i.e. it doesn't have a value for
546 reg[rrr]), the mapping is treated as identity.
547
548 The mapping is iterated for all maps in each map set (set of maps
549 separated by SEPARATOR) except in the case that lambda is
550 encountered. More precisely, the mapping proceeds as below:
551
552 At first, VAL0 is set to reg[rrr], and it is translated by the
553 first map to VAL1. Then, VAL1 is translated by the next map to
554 VAL2. This mapping is iterated until the last map is used. The
555 result of the mapping is the last value of VAL?. When the mapping
556 process reached to the end of the map set, it moves to the next
557 map set. If the next does not exit, the mapping process terminates,
558 and regard the last value as a result.
559
560 But, when VALm is mapped to VALn and VALn is not a number, the
561 mapping proceed as below:
562
563 If VALn is nil, the lastest map is ignored and the mapping of VALm
564 proceed to the next map.
565
566 In VALn is t, VALm is reverted to reg[rrr] and the mapping of VALm
567 proceed to the next map.
568
569 If VALn is lambda, move to the next map set like reaching to the
570 end of the current map set.
571
572 If VALn is a symbol, call the CCL program refered by it.
573 Then, use reg[rrr] as a mapped value except for -1, -2 and -3.
574 Such special values are regarded as nil, t, and lambda respectively.
575
576 Each map is a Lisp vector of the following format (a) or (b):
577 (a)......[STARTPOINT VAL1 VAL2 ...]
578 (b)......[t VAL STARTPOINT ENDPOINT],
579 where
580 STARTPOINT is an offset to be used for indexing a map,
581 ENDPOINT is a maximum index number of a map,
582 VAL and VALn is a number, nil, t, or lambda.
583
584 Valid index range of a map of type (a) is:
585 STARTPOINT <= index < STARTPOINT + map_size - 1
586 Valid index range of a map of type (b) is:
587 STARTPOINT <= index < ENDPOINT */
588
589 #define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
590 1:ExtendedCOMMNDXXXRRRrrrXXXXX
591 2:N-2
592 3:SEPARATOR_1 (< 0)
593 4:MAP-ID_1
594 5:MAP-ID_2
595 ...
596 M:SEPARATOR_x (< 0)
597 M+1:MAP-ID_y
598 ...
599 N:SEPARATOR_z (< 0)
600 */
601
602 #define MAX_MAP_SET_LEVEL 30
603
604 typedef struct
605 {
606 int rest_length;
607 int orig_val;
608 } tr_stack;
609
610 static tr_stack mapping_stack[MAX_MAP_SET_LEVEL];
611 static tr_stack *mapping_stack_pointer;
612
613 /* If this variable is non-zero, it indicates the stack_idx
614 of immediately called by CCL_MapMultiple. */
615 static int stack_idx_of_map_multiple;
616
617 #define PUSH_MAPPING_STACK(restlen, orig) \
618 do \
619 { \
620 mapping_stack_pointer->rest_length = (restlen); \
621 mapping_stack_pointer->orig_val = (orig); \
622 mapping_stack_pointer++; \
623 } \
624 while (0)
625
626 #define POP_MAPPING_STACK(restlen, orig) \
627 do \
628 { \
629 mapping_stack_pointer--; \
630 (restlen) = mapping_stack_pointer->rest_length; \
631 (orig) = mapping_stack_pointer->orig_val; \
632 } \
633 while (0)
634
635 #define CCL_CALL_FOR_MAP_INSTRUCTION(symbol, ret_ic) \
636 do \
637 { \
638 struct ccl_program called_ccl; \
639 if (stack_idx >= 256 \
640 || (setup_ccl_program (&called_ccl, (symbol)) != 0)) \
641 { \
642 if (stack_idx > 0) \
643 { \
644 ccl_prog = ccl_prog_stack_struct[0].ccl_prog; \
645 ic = ccl_prog_stack_struct[0].ic; \
646 eof_ic = ccl_prog_stack_struct[0].eof_ic; \
647 } \
648 CCL_INVALID_CMD; \
649 } \
650 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; \
651 ccl_prog_stack_struct[stack_idx].ic = (ret_ic); \
652 ccl_prog_stack_struct[stack_idx].eof_ic = eof_ic; \
653 stack_idx++; \
654 ccl_prog = called_ccl.prog; \
655 ic = CCL_HEADER_MAIN; \
656 eof_ic = XFASTINT (ccl_prog[CCL_HEADER_EOF]); \
657 goto ccl_repeat; \
658 } \
659 while (0)
660
661 #define CCL_MapSingle 0x12 /* Map by single code conversion map
662 1:ExtendedCOMMNDXXXRRRrrrXXXXX
663 2:MAP-ID
664 ------------------------------
665 Map reg[rrr] by MAP-ID.
666 If some valid mapping is found,
667 set reg[rrr] to the result,
668 else
669 set reg[RRR] to -1.
670 */
671
672 #define CCL_LookupIntConstTbl 0x13 /* Lookup multibyte character by
673 integer key. Afterwards R7 set
674 to 1 if lookup succeeded.
675 1:ExtendedCOMMNDRrrRRRXXXXXXXX
676 2:ARGUMENT(Hash table ID) */
677
678 #define CCL_LookupCharConstTbl 0x14 /* Lookup integer by multibyte
679 character key. Afterwards R7 set
680 to 1 if lookup succeeded.
681 1:ExtendedCOMMNDRrrRRRrrrXXXXX
682 2:ARGUMENT(Hash table ID) */
683
684 /* CCL arithmetic/logical operators. */
685 #define CCL_PLUS 0x00 /* X = Y + Z */
686 #define CCL_MINUS 0x01 /* X = Y - Z */
687 #define CCL_MUL 0x02 /* X = Y * Z */
688 #define CCL_DIV 0x03 /* X = Y / Z */
689 #define CCL_MOD 0x04 /* X = Y % Z */
690 #define CCL_AND 0x05 /* X = Y & Z */
691 #define CCL_OR 0x06 /* X = Y | Z */
692 #define CCL_XOR 0x07 /* X = Y ^ Z */
693 #define CCL_LSH 0x08 /* X = Y << Z */
694 #define CCL_RSH 0x09 /* X = Y >> Z */
695 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
696 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
697 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
698 #define CCL_LS 0x10 /* X = (X < Y) */
699 #define CCL_GT 0x11 /* X = (X > Y) */
700 #define CCL_EQ 0x12 /* X = (X == Y) */
701 #define CCL_LE 0x13 /* X = (X <= Y) */
702 #define CCL_GE 0x14 /* X = (X >= Y) */
703 #define CCL_NE 0x15 /* X = (X != Y) */
704
705 #define CCL_DECODE_SJIS 0x16 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
706 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
707 #define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z))
708 r[7] = LOWER_BYTE (SJIS (Y, Z) */
709
710 /* Terminate CCL program successfully. */
711 #define CCL_SUCCESS \
712 do \
713 { \
714 ccl->status = CCL_STAT_SUCCESS; \
715 goto ccl_finish; \
716 } \
717 while(0)
718
719 /* Suspend CCL program because of reading from empty input buffer or
720 writing to full output buffer. When this program is resumed, the
721 same I/O command is executed. */
722 #define CCL_SUSPEND(stat) \
723 do \
724 { \
725 ic--; \
726 ccl->status = stat; \
727 goto ccl_finish; \
728 } \
729 while (0)
730
731 /* Terminate CCL program because of invalid command. Should not occur
732 in the normal case. */
733 #ifndef CCL_DEBUG
734
735 #define CCL_INVALID_CMD \
736 do \
737 { \
738 ccl->status = CCL_STAT_INVALID_CMD; \
739 goto ccl_error_handler; \
740 } \
741 while(0)
742
743 #else
744
745 #define CCL_INVALID_CMD \
746 do \
747 { \
748 ccl_debug_hook (this_ic); \
749 ccl->status = CCL_STAT_INVALID_CMD; \
750 goto ccl_error_handler; \
751 } \
752 while(0)
753
754 #endif
755
756 /* Encode one character CH to multibyte form and write to the current
757 output buffer. If CH is less than 256, CH is written as is. */
758 #define CCL_WRITE_CHAR(ch) \
759 do { \
760 if (! dst) \
761 CCL_INVALID_CMD; \
762 else if (dst < dst_end) \
763 *dst++ = (ch); \
764 else \
765 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
766 } while (0)
767
768 /* Write a string at ccl_prog[IC] of length LEN to the current output
769 buffer. */
770 #define CCL_WRITE_STRING(len) \
771 do { \
772 int i; \
773 if (!dst) \
774 CCL_INVALID_CMD; \
775 else if (dst + len <= dst_end) \
776 { \
777 if (XFASTINT (ccl_prog[ic]) & 0x1000000) \
778 for (i = 0; i < len; i++) \
779 *dst++ = XFASTINT (ccl_prog[ic + i]) & 0xFFFFFF; \
780 else \
781 for (i = 0; i < len; i++) \
782 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
783 >> ((2 - (i % 3)) * 8)) & 0xFF; \
784 } \
785 else \
786 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
787 } while (0)
788
789 /* Read one byte from the current input buffer into Rth register. */
790 #define CCL_READ_CHAR(r) \
791 do { \
792 if (! src) \
793 CCL_INVALID_CMD; \
794 else if (src < src_end) \
795 r = *src++; \
796 else if (ccl->last_block) \
797 { \
798 r = -1; \
799 ic = ccl->eof_ic; \
800 goto ccl_repeat; \
801 } \
802 else \
803 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
804 } while (0)
805
806 /* Decode CODE by a charset whose id is ID. If ID is 0, return CODE
807 as is for backward compatibility. Assume that we can use the
808 variable `charset'. */
809
810 #define CCL_DECODE_CHAR(id, code) \
811 ((id) == 0 ? (code) \
812 : (charset = CHARSET_FROM_ID ((id)), DECODE_CHAR (charset, (code))))
813
814 /* Encode character C by some of charsets in CHARSET_LIST. Set ID to
815 the id of the used charset, ENCODED to the resulf of encoding.
816 Assume that we can use the variable `charset'. */
817
818 #define CCL_ENCODE_CHAR(c, charset_list, id, encoded) \
819 do { \
820 unsigned code; \
821 \
822 charset = char_charset ((c), (charset_list), &code); \
823 if (! charset && ! NILP (charset_list)) \
824 charset = char_charset ((c), Qnil, &code); \
825 if (charset) \
826 { \
827 (id) = CHARSET_ID (charset); \
828 (encoded) = code; \
829 } \
830 } while (0)
831
832 /* Execute CCL code on characters at SOURCE (length SRC_SIZE). The
833 resulting text goes to a place pointed by DESTINATION, the length
834 of which should not exceed DST_SIZE. As a side effect, how many
835 characters are consumed and produced are recorded in CCL->consumed
836 and CCL->produced, and the contents of CCL registers are updated.
837 If SOURCE or DESTINATION is NULL, only operations on registers are
838 permitted. */
839
840 #ifdef CCL_DEBUG
841 #define CCL_DEBUG_BACKTRACE_LEN 256
842 int ccl_backtrace_table[CCL_DEBUG_BACKTRACE_LEN];
843 int ccl_backtrace_idx;
844
845 int
846 ccl_debug_hook (int ic)
847 {
848 return ic;
849 }
850
851 #endif
852
853 struct ccl_prog_stack
854 {
855 Lisp_Object *ccl_prog; /* Pointer to an array of CCL code. */
856 int ic; /* Instruction Counter. */
857 int eof_ic; /* Instruction Counter to jump on EOF. */
858 };
859
860 /* For the moment, we only support depth 256 of stack. */
861 static struct ccl_prog_stack ccl_prog_stack_struct[256];
862
863 void
864 ccl_driver (ccl, source, destination, src_size, dst_size, charset_list)
865 struct ccl_program *ccl;
866 int *source, *destination;
867 int src_size, dst_size;
868 Lisp_Object charset_list;
869 {
870 register int *reg = ccl->reg;
871 register int ic = ccl->ic;
872 register int code = 0, field1, field2;
873 register Lisp_Object *ccl_prog = ccl->prog;
874 int *src = source, *src_end = src + src_size;
875 int *dst = destination, *dst_end = dst + dst_size;
876 int jump_address;
877 int i = 0, j, op;
878 int stack_idx = ccl->stack_idx;
879 /* Instruction counter of the current CCL code. */
880 int this_ic = 0;
881 struct charset *charset;
882 int eof_ic = ccl->eof_ic;
883 int eof_hit = 0;
884
885 if (ic >= eof_ic)
886 ic = CCL_HEADER_MAIN;
887
888 if (ccl->buf_magnification == 0) /* We can't read/produce any bytes. */
889 dst = NULL;
890
891 /* Set mapping stack pointer. */
892 mapping_stack_pointer = mapping_stack;
893
894 #ifdef CCL_DEBUG
895 ccl_backtrace_idx = 0;
896 #endif
897
898 for (;;)
899 {
900 ccl_repeat:
901 #ifdef CCL_DEBUG
902 ccl_backtrace_table[ccl_backtrace_idx++] = ic;
903 if (ccl_backtrace_idx >= CCL_DEBUG_BACKTRACE_LEN)
904 ccl_backtrace_idx = 0;
905 ccl_backtrace_table[ccl_backtrace_idx] = 0;
906 #endif
907
908 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
909 {
910 /* We can't just signal Qquit, instead break the loop as if
911 the whole data is processed. Don't reset Vquit_flag, it
912 must be handled later at a safer place. */
913 if (src)
914 src = source + src_size;
915 ccl->status = CCL_STAT_QUIT;
916 break;
917 }
918
919 this_ic = ic;
920 code = XINT (ccl_prog[ic]); ic++;
921 field1 = code >> 8;
922 field2 = (code & 0xFF) >> 5;
923
924 #define rrr field2
925 #define RRR (field1 & 7)
926 #define Rrr ((field1 >> 3) & 7)
927 #define ADDR field1
928 #define EXCMD (field1 >> 6)
929
930 switch (code & 0x1F)
931 {
932 case CCL_SetRegister: /* 00000000000000000RRRrrrXXXXX */
933 reg[rrr] = reg[RRR];
934 break;
935
936 case CCL_SetShortConst: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
937 reg[rrr] = field1;
938 break;
939
940 case CCL_SetConst: /* 00000000000000000000rrrXXXXX */
941 reg[rrr] = XINT (ccl_prog[ic]);
942 ic++;
943 break;
944
945 case CCL_SetArray: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
946 i = reg[RRR];
947 j = field1 >> 3;
948 if ((unsigned int) i < j)
949 reg[rrr] = XINT (ccl_prog[ic + i]);
950 ic += j;
951 break;
952
953 case CCL_Jump: /* A--D--D--R--E--S--S-000XXXXX */
954 ic += ADDR;
955 break;
956
957 case CCL_JumpCond: /* A--D--D--R--E--S--S-rrrXXXXX */
958 if (!reg[rrr])
959 ic += ADDR;
960 break;
961
962 case CCL_WriteRegisterJump: /* A--D--D--R--E--S--S-rrrXXXXX */
963 i = reg[rrr];
964 CCL_WRITE_CHAR (i);
965 ic += ADDR;
966 break;
967
968 case CCL_WriteRegisterReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
969 i = reg[rrr];
970 CCL_WRITE_CHAR (i);
971 ic++;
972 CCL_READ_CHAR (reg[rrr]);
973 ic += ADDR - 1;
974 break;
975
976 case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */
977 i = XINT (ccl_prog[ic]);
978 CCL_WRITE_CHAR (i);
979 ic += ADDR;
980 break;
981
982 case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
983 i = XINT (ccl_prog[ic]);
984 CCL_WRITE_CHAR (i);
985 ic++;
986 CCL_READ_CHAR (reg[rrr]);
987 ic += ADDR - 1;
988 break;
989
990 case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */
991 j = XINT (ccl_prog[ic]);
992 ic++;
993 CCL_WRITE_STRING (j);
994 ic += ADDR - 1;
995 break;
996
997 case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
998 i = reg[rrr];
999 j = XINT (ccl_prog[ic]);
1000 if ((unsigned int) i < j)
1001 {
1002 i = XINT (ccl_prog[ic + 1 + i]);
1003 CCL_WRITE_CHAR (i);
1004 }
1005 ic += j + 2;
1006 CCL_READ_CHAR (reg[rrr]);
1007 ic += ADDR - (j + 2);
1008 break;
1009
1010 case CCL_ReadJump: /* A--D--D--R--E--S--S-rrrYYYYY */
1011 CCL_READ_CHAR (reg[rrr]);
1012 ic += ADDR;
1013 break;
1014
1015 case CCL_ReadBranch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1016 CCL_READ_CHAR (reg[rrr]);
1017 /* fall through ... */
1018 case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1019 if ((unsigned int) reg[rrr] < field1)
1020 ic += XINT (ccl_prog[ic + reg[rrr]]);
1021 else
1022 ic += XINT (ccl_prog[ic + field1]);
1023 break;
1024
1025 case CCL_ReadRegister: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
1026 while (1)
1027 {
1028 CCL_READ_CHAR (reg[rrr]);
1029 if (!field1) break;
1030 code = XINT (ccl_prog[ic]); ic++;
1031 field1 = code >> 8;
1032 field2 = (code & 0xFF) >> 5;
1033 }
1034 break;
1035
1036 case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */
1037 rrr = 7;
1038 i = reg[RRR];
1039 j = XINT (ccl_prog[ic]);
1040 op = field1 >> 6;
1041 jump_address = ic + 1;
1042 goto ccl_set_expr;
1043
1044 case CCL_WriteRegister: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
1045 while (1)
1046 {
1047 i = reg[rrr];
1048 CCL_WRITE_CHAR (i);
1049 if (!field1) break;
1050 code = XINT (ccl_prog[ic]); ic++;
1051 field1 = code >> 8;
1052 field2 = (code & 0xFF) >> 5;
1053 }
1054 break;
1055
1056 case CCL_WriteExprRegister: /* 1:00000OPERATIONRrrRRR000XXXXX */
1057 rrr = 7;
1058 i = reg[RRR];
1059 j = reg[Rrr];
1060 op = field1 >> 6;
1061 jump_address = ic;
1062 goto ccl_set_expr;
1063
1064 case CCL_Call: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
1065 {
1066 Lisp_Object slot;
1067 int prog_id;
1068
1069 /* If FFF is nonzero, the CCL program ID is in the
1070 following code. */
1071 if (rrr)
1072 {
1073 prog_id = XINT (ccl_prog[ic]);
1074 ic++;
1075 }
1076 else
1077 prog_id = field1;
1078
1079 if (stack_idx >= 256
1080 || prog_id < 0
1081 || prog_id >= ASIZE (Vccl_program_table)
1082 || (slot = AREF (Vccl_program_table, prog_id), !VECTORP (slot))
1083 || !VECTORP (AREF (slot, 1)))
1084 {
1085 if (stack_idx > 0)
1086 {
1087 ccl_prog = ccl_prog_stack_struct[0].ccl_prog;
1088 ic = ccl_prog_stack_struct[0].ic;
1089 eof_ic = ccl_prog_stack_struct[0].eof_ic;
1090 }
1091 CCL_INVALID_CMD;
1092 }
1093
1094 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog;
1095 ccl_prog_stack_struct[stack_idx].ic = ic;
1096 ccl_prog_stack_struct[stack_idx].eof_ic = eof_ic;
1097 stack_idx++;
1098 ccl_prog = XVECTOR (AREF (slot, 1))->contents;
1099 ic = CCL_HEADER_MAIN;
1100 eof_ic = XFASTINT (ccl_prog[CCL_HEADER_EOF]);
1101 }
1102 break;
1103
1104 case CCL_WriteConstString: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1105 if (!rrr)
1106 CCL_WRITE_CHAR (field1);
1107 else
1108 {
1109 CCL_WRITE_STRING (field1);
1110 ic += (field1 + 2) / 3;
1111 }
1112 break;
1113
1114 case CCL_WriteArray: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1115 i = reg[rrr];
1116 if ((unsigned int) i < field1)
1117 {
1118 j = XINT (ccl_prog[ic + i]);
1119 CCL_WRITE_CHAR (j);
1120 }
1121 ic += field1;
1122 break;
1123
1124 case CCL_End: /* 0000000000000000000000XXXXX */
1125 if (stack_idx > 0)
1126 {
1127 stack_idx--;
1128 ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog;
1129 ic = ccl_prog_stack_struct[stack_idx].ic;
1130 eof_ic = ccl_prog_stack_struct[stack_idx].eof_ic;
1131 if (eof_hit)
1132 ic = eof_ic;
1133 break;
1134 }
1135 if (src)
1136 src = src_end;
1137 /* ccl->ic should points to this command code again to
1138 suppress further processing. */
1139 ic--;
1140 CCL_SUCCESS;
1141
1142 case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */
1143 i = XINT (ccl_prog[ic]);
1144 ic++;
1145 op = field1 >> 6;
1146 goto ccl_expr_self;
1147
1148 case CCL_ExprSelfReg: /* 00000OPERATION000RRRrrrXXXXX */
1149 i = reg[RRR];
1150 op = field1 >> 6;
1151
1152 ccl_expr_self:
1153 switch (op)
1154 {
1155 case CCL_PLUS: reg[rrr] += i; break;
1156 case CCL_MINUS: reg[rrr] -= i; break;
1157 case CCL_MUL: reg[rrr] *= i; break;
1158 case CCL_DIV: reg[rrr] /= i; break;
1159 case CCL_MOD: reg[rrr] %= i; break;
1160 case CCL_AND: reg[rrr] &= i; break;
1161 case CCL_OR: reg[rrr] |= i; break;
1162 case CCL_XOR: reg[rrr] ^= i; break;
1163 case CCL_LSH: reg[rrr] <<= i; break;
1164 case CCL_RSH: reg[rrr] >>= i; break;
1165 case CCL_LSH8: reg[rrr] <<= 8; reg[rrr] |= i; break;
1166 case CCL_RSH8: reg[7] = reg[rrr] & 0xFF; reg[rrr] >>= 8; break;
1167 case CCL_DIVMOD: reg[7] = reg[rrr] % i; reg[rrr] /= i; break;
1168 case CCL_LS: reg[rrr] = reg[rrr] < i; break;
1169 case CCL_GT: reg[rrr] = reg[rrr] > i; break;
1170 case CCL_EQ: reg[rrr] = reg[rrr] == i; break;
1171 case CCL_LE: reg[rrr] = reg[rrr] <= i; break;
1172 case CCL_GE: reg[rrr] = reg[rrr] >= i; break;
1173 case CCL_NE: reg[rrr] = reg[rrr] != i; break;
1174 default: CCL_INVALID_CMD;
1175 }
1176 break;
1177
1178 case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */
1179 i = reg[RRR];
1180 j = XINT (ccl_prog[ic]);
1181 op = field1 >> 6;
1182 jump_address = ++ic;
1183 goto ccl_set_expr;
1184
1185 case CCL_SetExprReg: /* 00000OPERATIONRrrRRRrrrXXXXX */
1186 i = reg[RRR];
1187 j = reg[Rrr];
1188 op = field1 >> 6;
1189 jump_address = ic;
1190 goto ccl_set_expr;
1191
1192 case CCL_ReadJumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1193 CCL_READ_CHAR (reg[rrr]);
1194 case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1195 i = reg[rrr];
1196 op = XINT (ccl_prog[ic]);
1197 jump_address = ic++ + ADDR;
1198 j = XINT (ccl_prog[ic]);
1199 ic++;
1200 rrr = 7;
1201 goto ccl_set_expr;
1202
1203 case CCL_ReadJumpCondExprReg: /* A--D--D--R--E--S--S-rrrXXXXX */
1204 CCL_READ_CHAR (reg[rrr]);
1205 case CCL_JumpCondExprReg:
1206 i = reg[rrr];
1207 op = XINT (ccl_prog[ic]);
1208 jump_address = ic++ + ADDR;
1209 j = reg[XINT (ccl_prog[ic])];
1210 ic++;
1211 rrr = 7;
1212
1213 ccl_set_expr:
1214 switch (op)
1215 {
1216 case CCL_PLUS: reg[rrr] = i + j; break;
1217 case CCL_MINUS: reg[rrr] = i - j; break;
1218 case CCL_MUL: reg[rrr] = i * j; break;
1219 case CCL_DIV: reg[rrr] = i / j; break;
1220 case CCL_MOD: reg[rrr] = i % j; break;
1221 case CCL_AND: reg[rrr] = i & j; break;
1222 case CCL_OR: reg[rrr] = i | j; break;
1223 case CCL_XOR: reg[rrr] = i ^ j; break;
1224 case CCL_LSH: reg[rrr] = i << j; break;
1225 case CCL_RSH: reg[rrr] = i >> j; break;
1226 case CCL_LSH8: reg[rrr] = (i << 8) | j; break;
1227 case CCL_RSH8: reg[rrr] = i >> 8; reg[7] = i & 0xFF; break;
1228 case CCL_DIVMOD: reg[rrr] = i / j; reg[7] = i % j; break;
1229 case CCL_LS: reg[rrr] = i < j; break;
1230 case CCL_GT: reg[rrr] = i > j; break;
1231 case CCL_EQ: reg[rrr] = i == j; break;
1232 case CCL_LE: reg[rrr] = i <= j; break;
1233 case CCL_GE: reg[rrr] = i >= j; break;
1234 case CCL_NE: reg[rrr] = i != j; break;
1235 case CCL_DECODE_SJIS:
1236 {
1237 i = (i << 8) | j;
1238 SJIS_TO_JIS (i);
1239 reg[rrr] = i >> 8;
1240 reg[7] = i & 0xFF;
1241 break;
1242 }
1243 case CCL_ENCODE_SJIS:
1244 {
1245 i = (i << 8) | j;
1246 JIS_TO_SJIS (i);
1247 reg[rrr] = i >> 8;
1248 reg[7] = i & 0xFF;
1249 break;
1250 }
1251 default: CCL_INVALID_CMD;
1252 }
1253 code &= 0x1F;
1254 if (code == CCL_WriteExprConst || code == CCL_WriteExprRegister)
1255 {
1256 i = reg[rrr];
1257 CCL_WRITE_CHAR (i);
1258 ic = jump_address;
1259 }
1260 else if (!reg[rrr])
1261 ic = jump_address;
1262 break;
1263
1264 case CCL_Extension:
1265 switch (EXCMD)
1266 {
1267 case CCL_ReadMultibyteChar2:
1268 if (!src)
1269 CCL_INVALID_CMD;
1270 CCL_READ_CHAR (i);
1271 CCL_ENCODE_CHAR (i, charset_list, reg[RRR], reg[rrr]);
1272 break;
1273
1274 case CCL_WriteMultibyteChar2:
1275 if (! dst)
1276 CCL_INVALID_CMD;
1277 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1278 CCL_WRITE_CHAR (i);
1279 break;
1280
1281 case CCL_TranslateCharacter:
1282 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1283 op = translate_char (GET_TRANSLATION_TABLE (reg[Rrr]), i);
1284 CCL_ENCODE_CHAR (op, charset_list, reg[RRR], reg[rrr]);
1285 break;
1286
1287 case CCL_TranslateCharacterConstTbl:
1288 op = XINT (ccl_prog[ic]); /* table */
1289 ic++;
1290 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1291 op = translate_char (GET_TRANSLATION_TABLE (op), i);
1292 CCL_ENCODE_CHAR (op, charset_list, reg[RRR], reg[rrr]);
1293 break;
1294
1295 case CCL_LookupIntConstTbl:
1296 op = XINT (ccl_prog[ic]); /* table */
1297 ic++;
1298 {
1299 struct Lisp_Hash_Table *h = GET_HASH_TABLE (op);
1300
1301 op = hash_lookup (h, make_number (reg[RRR]), NULL);
1302 if (op >= 0)
1303 {
1304 Lisp_Object opl;
1305 opl = HASH_VALUE (h, op);
1306 if (! CHARACTERP (opl))
1307 CCL_INVALID_CMD;
1308 reg[RRR] = charset_unicode;
1309 reg[rrr] = op;
1310 reg[7] = 1; /* r7 true for success */
1311 }
1312 else
1313 reg[7] = 0;
1314 }
1315 break;
1316
1317 case CCL_LookupCharConstTbl:
1318 op = XINT (ccl_prog[ic]); /* table */
1319 ic++;
1320 i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
1321 {
1322 struct Lisp_Hash_Table *h = GET_HASH_TABLE (op);
1323
1324 op = hash_lookup (h, make_number (i), NULL);
1325 if (op >= 0)
1326 {
1327 Lisp_Object opl;
1328 opl = HASH_VALUE (h, op);
1329 if (!INTEGERP (opl))
1330 CCL_INVALID_CMD;
1331 reg[RRR] = XINT (opl);
1332 reg[7] = 1; /* r7 true for success */
1333 }
1334 else
1335 reg[7] = 0;
1336 }
1337 break;
1338
1339 case CCL_IterateMultipleMap:
1340 {
1341 Lisp_Object map, content, attrib, value;
1342 int point, size, fin_ic;
1343
1344 j = XINT (ccl_prog[ic++]); /* number of maps. */
1345 fin_ic = ic + j;
1346 op = reg[rrr];
1347 if ((j > reg[RRR]) && (j >= 0))
1348 {
1349 ic += reg[RRR];
1350 i = reg[RRR];
1351 }
1352 else
1353 {
1354 reg[RRR] = -1;
1355 ic = fin_ic;
1356 break;
1357 }
1358
1359 for (;i < j;i++)
1360 {
1361
1362 size = ASIZE (Vcode_conversion_map_vector);
1363 point = XINT (ccl_prog[ic++]);
1364 if (point >= size) continue;
1365 map = AREF (Vcode_conversion_map_vector, point);
1366
1367 /* Check map varidity. */
1368 if (!CONSP (map)) continue;
1369 map = XCDR (map);
1370 if (!VECTORP (map)) continue;
1371 size = ASIZE (map);
1372 if (size <= 1) continue;
1373
1374 content = AREF (map, 0);
1375
1376 /* check map type,
1377 [STARTPOINT VAL1 VAL2 ...] or
1378 [t ELELMENT STARTPOINT ENDPOINT] */
1379 if (NUMBERP (content))
1380 {
1381 point = XUINT (content);
1382 point = op - point + 1;
1383 if (!((point >= 1) && (point < size))) continue;
1384 content = AREF (map, point);
1385 }
1386 else if (EQ (content, Qt))
1387 {
1388 if (size != 4) continue;
1389 if ((op >= XUINT (AREF (map, 2)))
1390 && (op < XUINT (AREF (map, 3))))
1391 content = AREF (map, 1);
1392 else
1393 continue;
1394 }
1395 else
1396 continue;
1397
1398 if (NILP (content))
1399 continue;
1400 else if (NUMBERP (content))
1401 {
1402 reg[RRR] = i;
1403 reg[rrr] = XINT(content);
1404 break;
1405 }
1406 else if (EQ (content, Qt) || EQ (content, Qlambda))
1407 {
1408 reg[RRR] = i;
1409 break;
1410 }
1411 else if (CONSP (content))
1412 {
1413 attrib = XCAR (content);
1414 value = XCDR (content);
1415 if (!NUMBERP (attrib) || !NUMBERP (value))
1416 continue;
1417 reg[RRR] = i;
1418 reg[rrr] = XUINT (value);
1419 break;
1420 }
1421 else if (SYMBOLP (content))
1422 CCL_CALL_FOR_MAP_INSTRUCTION (content, fin_ic);
1423 else
1424 CCL_INVALID_CMD;
1425 }
1426 if (i == j)
1427 reg[RRR] = -1;
1428 ic = fin_ic;
1429 }
1430 break;
1431
1432 case CCL_MapMultiple:
1433 {
1434 Lisp_Object map, content, attrib, value;
1435 int point, size, map_vector_size;
1436 int map_set_rest_length, fin_ic;
1437 int current_ic = this_ic;
1438
1439 /* inhibit recursive call on MapMultiple. */
1440 if (stack_idx_of_map_multiple > 0)
1441 {
1442 if (stack_idx_of_map_multiple <= stack_idx)
1443 {
1444 stack_idx_of_map_multiple = 0;
1445 mapping_stack_pointer = mapping_stack;
1446 CCL_INVALID_CMD;
1447 }
1448 }
1449 else
1450 mapping_stack_pointer = mapping_stack;
1451 stack_idx_of_map_multiple = 0;
1452
1453 map_set_rest_length =
1454 XINT (ccl_prog[ic++]); /* number of maps and separators. */
1455 fin_ic = ic + map_set_rest_length;
1456 op = reg[rrr];
1457
1458 if ((map_set_rest_length > reg[RRR]) && (reg[RRR] >= 0))
1459 {
1460 ic += reg[RRR];
1461 i = reg[RRR];
1462 map_set_rest_length -= i;
1463 }
1464 else
1465 {
1466 ic = fin_ic;
1467 reg[RRR] = -1;
1468 mapping_stack_pointer = mapping_stack;
1469 break;
1470 }
1471
1472 if (mapping_stack_pointer <= (mapping_stack + 1))
1473 {
1474 /* Set up initial state. */
1475 mapping_stack_pointer = mapping_stack;
1476 PUSH_MAPPING_STACK (0, op);
1477 reg[RRR] = -1;
1478 }
1479 else
1480 {
1481 /* Recover after calling other ccl program. */
1482 int orig_op;
1483
1484 POP_MAPPING_STACK (map_set_rest_length, orig_op);
1485 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1486 switch (op)
1487 {
1488 case -1:
1489 /* Regard it as Qnil. */
1490 op = orig_op;
1491 i++;
1492 ic++;
1493 map_set_rest_length--;
1494 break;
1495 case -2:
1496 /* Regard it as Qt. */
1497 op = reg[rrr];
1498 i++;
1499 ic++;
1500 map_set_rest_length--;
1501 break;
1502 case -3:
1503 /* Regard it as Qlambda. */
1504 op = orig_op;
1505 i += map_set_rest_length;
1506 ic += map_set_rest_length;
1507 map_set_rest_length = 0;
1508 break;
1509 default:
1510 /* Regard it as normal mapping. */
1511 i += map_set_rest_length;
1512 ic += map_set_rest_length;
1513 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1514 break;
1515 }
1516 }
1517 map_vector_size = ASIZE (Vcode_conversion_map_vector);
1518
1519 do {
1520 for (;map_set_rest_length > 0;i++, ic++, map_set_rest_length--)
1521 {
1522 point = XINT(ccl_prog[ic]);
1523 if (point < 0)
1524 {
1525 /* +1 is for including separator. */
1526 point = -point + 1;
1527 if (mapping_stack_pointer
1528 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1529 CCL_INVALID_CMD;
1530 PUSH_MAPPING_STACK (map_set_rest_length - point,
1531 reg[rrr]);
1532 map_set_rest_length = point;
1533 reg[rrr] = op;
1534 continue;
1535 }
1536
1537 if (point >= map_vector_size) continue;
1538 map = AREF (Vcode_conversion_map_vector, point);
1539
1540 /* Check map varidity. */
1541 if (!CONSP (map)) continue;
1542 map = XCDR (map);
1543 if (!VECTORP (map)) continue;
1544 size = ASIZE (map);
1545 if (size <= 1) continue;
1546
1547 content = AREF (map, 0);
1548
1549 /* check map type,
1550 [STARTPOINT VAL1 VAL2 ...] or
1551 [t ELEMENT STARTPOINT ENDPOINT] */
1552 if (NUMBERP (content))
1553 {
1554 point = XUINT (content);
1555 point = op - point + 1;
1556 if (!((point >= 1) && (point < size))) continue;
1557 content = AREF (map, point);
1558 }
1559 else if (EQ (content, Qt))
1560 {
1561 if (size != 4) continue;
1562 if ((op >= XUINT (AREF (map, 2))) &&
1563 (op < XUINT (AREF (map, 3))))
1564 content = AREF (map, 1);
1565 else
1566 continue;
1567 }
1568 else
1569 continue;
1570
1571 if (NILP (content))
1572 continue;
1573
1574 reg[RRR] = i;
1575 if (NUMBERP (content))
1576 {
1577 op = XINT (content);
1578 i += map_set_rest_length - 1;
1579 ic += map_set_rest_length - 1;
1580 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1581 map_set_rest_length++;
1582 }
1583 else if (CONSP (content))
1584 {
1585 attrib = XCAR (content);
1586 value = XCDR (content);
1587 if (!NUMBERP (attrib) || !NUMBERP (value))
1588 continue;
1589 op = XUINT (value);
1590 i += map_set_rest_length - 1;
1591 ic += map_set_rest_length - 1;
1592 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1593 map_set_rest_length++;
1594 }
1595 else if (EQ (content, Qt))
1596 {
1597 op = reg[rrr];
1598 }
1599 else if (EQ (content, Qlambda))
1600 {
1601 i += map_set_rest_length;
1602 ic += map_set_rest_length;
1603 break;
1604 }
1605 else if (SYMBOLP (content))
1606 {
1607 if (mapping_stack_pointer
1608 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1609 CCL_INVALID_CMD;
1610 PUSH_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1611 PUSH_MAPPING_STACK (map_set_rest_length, op);
1612 stack_idx_of_map_multiple = stack_idx + 1;
1613 CCL_CALL_FOR_MAP_INSTRUCTION (content, current_ic);
1614 }
1615 else
1616 CCL_INVALID_CMD;
1617 }
1618 if (mapping_stack_pointer <= (mapping_stack + 1))
1619 break;
1620 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1621 i += map_set_rest_length;
1622 ic += map_set_rest_length;
1623 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1624 } while (1);
1625
1626 ic = fin_ic;
1627 }
1628 reg[rrr] = op;
1629 break;
1630
1631 case CCL_MapSingle:
1632 {
1633 Lisp_Object map, attrib, value, content;
1634 int size, point;
1635 j = XINT (ccl_prog[ic++]); /* map_id */
1636 op = reg[rrr];
1637 if (j >= ASIZE (Vcode_conversion_map_vector))
1638 {
1639 reg[RRR] = -1;
1640 break;
1641 }
1642 map = AREF (Vcode_conversion_map_vector, j);
1643 if (!CONSP (map))
1644 {
1645 reg[RRR] = -1;
1646 break;
1647 }
1648 map = XCDR (map);
1649 if (!VECTORP (map))
1650 {
1651 reg[RRR] = -1;
1652 break;
1653 }
1654 size = ASIZE (map);
1655 point = XUINT (AREF (map, 0));
1656 point = op - point + 1;
1657 reg[RRR] = 0;
1658 if ((size <= 1) ||
1659 (!((point >= 1) && (point < size))))
1660 reg[RRR] = -1;
1661 else
1662 {
1663 reg[RRR] = 0;
1664 content = AREF (map, point);
1665 if (NILP (content))
1666 reg[RRR] = -1;
1667 else if (NUMBERP (content))
1668 reg[rrr] = XINT (content);
1669 else if (EQ (content, Qt));
1670 else if (CONSP (content))
1671 {
1672 attrib = XCAR (content);
1673 value = XCDR (content);
1674 if (!NUMBERP (attrib) || !NUMBERP (value))
1675 continue;
1676 reg[rrr] = XUINT(value);
1677 break;
1678 }
1679 else if (SYMBOLP (content))
1680 CCL_CALL_FOR_MAP_INSTRUCTION (content, ic);
1681 else
1682 reg[RRR] = -1;
1683 }
1684 }
1685 break;
1686
1687 default:
1688 CCL_INVALID_CMD;
1689 }
1690 break;
1691
1692 default:
1693 CCL_INVALID_CMD;
1694 }
1695 }
1696
1697 ccl_error_handler:
1698 /* The suppress_error member is set when e.g. a CCL-based coding
1699 system is used for terminal output. */
1700 if (!ccl->suppress_error && destination)
1701 {
1702 /* We can insert an error message only if DESTINATION is
1703 specified and we still have a room to store the message
1704 there. */
1705 char msg[256];
1706 int msglen;
1707
1708 if (!dst)
1709 dst = destination;
1710
1711 switch (ccl->status)
1712 {
1713 case CCL_STAT_INVALID_CMD:
1714 sprintf(msg, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1715 code & 0x1F, code, this_ic);
1716 #ifdef CCL_DEBUG
1717 {
1718 int i = ccl_backtrace_idx - 1;
1719 int j;
1720
1721 msglen = strlen (msg);
1722 if (dst + msglen <= (dst_bytes ? dst_end : src))
1723 {
1724 bcopy (msg, dst, msglen);
1725 dst += msglen;
1726 }
1727
1728 for (j = 0; j < CCL_DEBUG_BACKTRACE_LEN; j++, i--)
1729 {
1730 if (i < 0) i = CCL_DEBUG_BACKTRACE_LEN - 1;
1731 if (ccl_backtrace_table[i] == 0)
1732 break;
1733 sprintf(msg, " %d", ccl_backtrace_table[i]);
1734 msglen = strlen (msg);
1735 if (dst + msglen > (dst_bytes ? dst_end : src))
1736 break;
1737 bcopy (msg, dst, msglen);
1738 dst += msglen;
1739 }
1740 goto ccl_finish;
1741 }
1742 #endif
1743 break;
1744
1745 case CCL_STAT_QUIT:
1746 if (! ccl->quit_silently)
1747 sprintf(msg, "\nCCL: Quited.");
1748 break;
1749
1750 default:
1751 sprintf(msg, "\nCCL: Unknown error type (%d)", ccl->status);
1752 }
1753
1754 msglen = strlen (msg);
1755 if (dst + msglen <= dst_end)
1756 {
1757 for (i = 0; i < msglen; i++)
1758 *dst++ = msg[i];
1759 }
1760
1761 if (ccl->status == CCL_STAT_INVALID_CMD)
1762 {
1763 #if 0 /* If the remaining bytes contain 0x80..0x9F, copying them
1764 results in an invalid multibyte sequence. */
1765
1766 /* Copy the remaining source data. */
1767 int i = src_end - src;
1768 if (dst_bytes && (dst_end - dst) < i)
1769 i = dst_end - dst;
1770 bcopy (src, dst, i);
1771 src += i;
1772 dst += i;
1773 #else
1774 /* Signal that we've consumed everything. */
1775 src = src_end;
1776 #endif
1777 }
1778 }
1779
1780 ccl_finish:
1781 ccl->ic = ic;
1782 ccl->stack_idx = stack_idx;
1783 ccl->prog = ccl_prog;
1784 ccl->consumed = src - source;
1785 if (dst != NULL)
1786 ccl->produced = dst - destination;
1787 else
1788 ccl->produced = 0;
1789 }
1790
1791 /* Resolve symbols in the specified CCL code (Lisp vector). This
1792 function converts symbols of code conversion maps and character
1793 translation tables embeded in the CCL code into their ID numbers.
1794
1795 The return value is a vector (CCL itself or a new vector in which
1796 all symbols are resolved), Qt if resolving of some symbol failed,
1797 or nil if CCL contains invalid data. */
1798
1799 static Lisp_Object
1800 resolve_symbol_ccl_program (ccl)
1801 Lisp_Object ccl;
1802 {
1803 int i, veclen, unresolved = 0;
1804 Lisp_Object result, contents, val;
1805
1806 result = ccl;
1807 veclen = ASIZE (result);
1808
1809 for (i = 0; i < veclen; i++)
1810 {
1811 contents = AREF (result, i);
1812 if (INTEGERP (contents))
1813 continue;
1814 else if (CONSP (contents)
1815 && SYMBOLP (XCAR (contents))
1816 && SYMBOLP (XCDR (contents)))
1817 {
1818 /* This is the new style for embedding symbols. The form is
1819 (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
1820 an index number. */
1821
1822 if (EQ (result, ccl))
1823 result = Fcopy_sequence (ccl);
1824
1825 val = Fget (XCAR (contents), XCDR (contents));
1826 if (NATNUMP (val))
1827 ASET (result, i, val);
1828 else
1829 unresolved = 1;
1830 continue;
1831 }
1832 else if (SYMBOLP (contents))
1833 {
1834 /* This is the old style for embedding symbols. This style
1835 may lead to a bug if, for instance, a translation table
1836 and a code conversion map have the same name. */
1837 if (EQ (result, ccl))
1838 result = Fcopy_sequence (ccl);
1839
1840 val = Fget (contents, Qtranslation_table_id);
1841 if (NATNUMP (val))
1842 ASET (result, i, val);
1843 else
1844 {
1845 val = Fget (contents, Qcode_conversion_map_id);
1846 if (NATNUMP (val))
1847 ASET (result, i, val);
1848 else
1849 {
1850 val = Fget (contents, Qccl_program_idx);
1851 if (NATNUMP (val))
1852 ASET (result, i, val);
1853 else
1854 unresolved = 1;
1855 }
1856 }
1857 continue;
1858 }
1859 return Qnil;
1860 }
1861
1862 return (unresolved ? Qt : result);
1863 }
1864
1865 /* Return the compiled code (vector) of CCL program CCL_PROG.
1866 CCL_PROG is a name (symbol) of the program or already compiled
1867 code. If necessary, resolve symbols in the compiled code to index
1868 numbers. If we failed to get the compiled code or to resolve
1869 symbols, return Qnil. */
1870
1871 static Lisp_Object
1872 ccl_get_compiled_code (ccl_prog, idx)
1873 Lisp_Object ccl_prog;
1874 int *idx;
1875 {
1876 Lisp_Object val, slot;
1877
1878 if (VECTORP (ccl_prog))
1879 {
1880 val = resolve_symbol_ccl_program (ccl_prog);
1881 *idx = -1;
1882 return (VECTORP (val) ? val : Qnil);
1883 }
1884 if (!SYMBOLP (ccl_prog))
1885 return Qnil;
1886
1887 val = Fget (ccl_prog, Qccl_program_idx);
1888 if (! NATNUMP (val)
1889 || XINT (val) >= ASIZE (Vccl_program_table))
1890 return Qnil;
1891 slot = AREF (Vccl_program_table, XINT (val));
1892 if (! VECTORP (slot)
1893 || ASIZE (slot) != 4
1894 || ! VECTORP (AREF (slot, 1)))
1895 return Qnil;
1896 *idx = XINT (val);
1897 if (NILP (AREF (slot, 2)))
1898 {
1899 val = resolve_symbol_ccl_program (AREF (slot, 1));
1900 if (! VECTORP (val))
1901 return Qnil;
1902 ASET (slot, 1, val);
1903 ASET (slot, 2, Qt);
1904 }
1905 return AREF (slot, 1);
1906 }
1907
1908 /* Setup fields of the structure pointed by CCL appropriately for the
1909 execution of CCL program CCL_PROG. CCL_PROG is the name (symbol)
1910 of the CCL program or the already compiled code (vector).
1911 Return 0 if we succeed this setup, else return -1.
1912
1913 If CCL_PROG is nil, we just reset the structure pointed by CCL. */
1914 int
1915 setup_ccl_program (ccl, ccl_prog)
1916 struct ccl_program *ccl;
1917 Lisp_Object ccl_prog;
1918 {
1919 int i;
1920
1921 if (! NILP (ccl_prog))
1922 {
1923 struct Lisp_Vector *vp;
1924
1925 ccl_prog = ccl_get_compiled_code (ccl_prog, &ccl->idx);
1926 if (! VECTORP (ccl_prog))
1927 return -1;
1928 vp = XVECTOR (ccl_prog);
1929 ccl->size = vp->size;
1930 ccl->prog = vp->contents;
1931 ccl->eof_ic = XINT (vp->contents[CCL_HEADER_EOF]);
1932 ccl->buf_magnification = XINT (vp->contents[CCL_HEADER_BUF_MAG]);
1933 if (ccl->idx >= 0)
1934 {
1935 Lisp_Object slot;
1936
1937 slot = AREF (Vccl_program_table, ccl->idx);
1938 ASET (slot, 3, Qnil);
1939 }
1940 }
1941 ccl->ic = CCL_HEADER_MAIN;
1942 for (i = 0; i < 8; i++)
1943 ccl->reg[i] = 0;
1944 ccl->last_block = 0;
1945 ccl->private_state = 0;
1946 ccl->status = 0;
1947 ccl->stack_idx = 0;
1948 ccl->suppress_error = 0;
1949 ccl->eight_bit_control = 0;
1950 ccl->quit_silently = 0;
1951 return 0;
1952 }
1953
1954
1955 /* Check if CCL is updated or not. If not, re-setup members of CCL. */
1956
1957 int
1958 check_ccl_update (ccl)
1959 struct ccl_program *ccl;
1960 {
1961 Lisp_Object slot, ccl_prog;
1962
1963 if (ccl->idx < 0)
1964 return 0;
1965 slot = AREF (Vccl_program_table, ccl->idx);
1966 if (NILP (AREF (slot, 3)))
1967 return 0;
1968 ccl_prog = ccl_get_compiled_code (AREF (slot, 0), &ccl->idx);
1969 if (! VECTORP (ccl_prog))
1970 return -1;
1971 ccl->size = ASIZE (ccl_prog);
1972 ccl->prog = XVECTOR (ccl_prog)->contents;
1973 ccl->eof_ic = XINT (AREF (ccl_prog, CCL_HEADER_EOF));
1974 ccl->buf_magnification = XINT (AREF (ccl_prog, CCL_HEADER_BUF_MAG));
1975 ASET (slot, 3, Qnil);
1976 return 0;
1977 }
1978
1979
1980 DEFUN ("ccl-program-p", Fccl_program_p, Sccl_program_p, 1, 1, 0,
1981 doc: /* Return t if OBJECT is a CCL program name or a compiled CCL program code.
1982 See the documentation of `define-ccl-program' for the detail of CCL program. */)
1983 (object)
1984 Lisp_Object object;
1985 {
1986 Lisp_Object val;
1987
1988 if (VECTORP (object))
1989 {
1990 val = resolve_symbol_ccl_program (object);
1991 return (VECTORP (val) ? Qt : Qnil);
1992 }
1993 if (!SYMBOLP (object))
1994 return Qnil;
1995
1996 val = Fget (object, Qccl_program_idx);
1997 return ((! NATNUMP (val)
1998 || XINT (val) >= ASIZE (Vccl_program_table))
1999 ? Qnil : Qt);
2000 }
2001
2002 DEFUN ("ccl-execute", Fccl_execute, Sccl_execute, 2, 2, 0,
2003 doc: /* Execute CCL-PROGRAM with registers initialized by REGISTERS.
2004
2005 CCL-PROGRAM is a CCL program name (symbol)
2006 or compiled code generated by `ccl-compile' (for backward compatibility.
2007 In the latter case, the execution overhead is bigger than in the former).
2008 No I/O commands should appear in CCL-PROGRAM.
2009
2010 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value
2011 for the Nth register.
2012
2013 As side effect, each element of REGISTERS holds the value of
2014 the corresponding register after the execution.
2015
2016 See the documentation of `define-ccl-program' for a definition of CCL
2017 programs. */)
2018 (ccl_prog, reg)
2019 Lisp_Object ccl_prog, reg;
2020 {
2021 struct ccl_program ccl;
2022 int i;
2023
2024 if (setup_ccl_program (&ccl, ccl_prog) < 0)
2025 error ("Invalid CCL program");
2026
2027 CHECK_VECTOR (reg);
2028 if (ASIZE (reg) != 8)
2029 error ("Length of vector REGISTERS is not 8");
2030
2031 for (i = 0; i < 8; i++)
2032 ccl.reg[i] = (INTEGERP (AREF (reg, i))
2033 ? XINT (AREF (reg, i))
2034 : 0);
2035
2036 ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil);
2037 QUIT;
2038 if (ccl.status != CCL_STAT_SUCCESS)
2039 error ("Error in CCL program at %dth code", ccl.ic);
2040
2041 for (i = 0; i < 8; i++)
2042 ASET (reg, i, make_number (ccl.reg[i]));
2043 return Qnil;
2044 }
2045
2046 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, Sccl_execute_on_string,
2047 3, 5, 0,
2048 doc: /* Execute CCL-PROGRAM with initial STATUS on STRING.
2049
2050 CCL-PROGRAM is a symbol registered by `register-ccl-program',
2051 or a compiled code generated by `ccl-compile' (for backward compatibility,
2052 in this case, the execution is slower).
2053
2054 Read buffer is set to STRING, and write buffer is allocated automatically.
2055
2056 STATUS is a vector of [R0 R1 ... R7 IC], where
2057 R0..R7 are initial values of corresponding registers,
2058 IC is the instruction counter specifying from where to start the program.
2059 If R0..R7 are nil, they are initialized to 0.
2060 If IC is nil, it is initialized to head of the CCL program.
2061
2062 If optional 4th arg CONTINUE is non-nil, keep IC on read operation
2063 when read buffer is exausted, else, IC is always set to the end of
2064 CCL-PROGRAM on exit.
2065
2066 It returns the contents of write buffer as a string,
2067 and as side effect, STATUS is updated.
2068 If the optional 5th arg UNIBYTE-P is non-nil, the returned string
2069 is a unibyte string. By default it is a multibyte string.
2070
2071 See the documentation of `define-ccl-program' for the detail of CCL program.
2072 usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBYTE-P) */)
2073 (ccl_prog, status, str, contin, unibyte_p)
2074 Lisp_Object ccl_prog, status, str, contin, unibyte_p;
2075 {
2076 Lisp_Object val;
2077 struct ccl_program ccl;
2078 int i;
2079 int outbufsize;
2080 unsigned char *outbuf, *outp;
2081 int str_chars, str_bytes;
2082 #define CCL_EXECUTE_BUF_SIZE 1024
2083 int source[CCL_EXECUTE_BUF_SIZE], destination[CCL_EXECUTE_BUF_SIZE];
2084 int consumed_chars, consumed_bytes, produced_chars;
2085
2086 if (setup_ccl_program (&ccl, ccl_prog) < 0)
2087 error ("Invalid CCL program");
2088
2089 CHECK_VECTOR (status);
2090 if (ASIZE (status) != 9)
2091 error ("Length of vector STATUS is not 9");
2092 CHECK_STRING (str);
2093
2094 str_chars = SCHARS (str);
2095 str_bytes = SBYTES (str);
2096
2097 for (i = 0; i < 8; i++)
2098 {
2099 if (NILP (AREF (status, i)))
2100 ASET (status, i, make_number (0));
2101 if (INTEGERP (AREF (status, i)))
2102 ccl.reg[i] = XINT (AREF (status, i));
2103 }
2104 if (INTEGERP (AREF (status, i)))
2105 {
2106 i = XFASTINT (AREF (status, 8));
2107 if (ccl.ic < i && i < ccl.size)
2108 ccl.ic = i;
2109 }
2110
2111 outbufsize = (ccl.buf_magnification
2112 ? str_bytes * ccl.buf_magnification + 256
2113 : str_bytes + 256);
2114 outp = outbuf = (unsigned char *) xmalloc (outbufsize);
2115
2116 consumed_chars = consumed_bytes = 0;
2117 produced_chars = 0;
2118 while (1)
2119 {
2120 const unsigned char *p = SDATA (str) + consumed_bytes;
2121 const unsigned char *endp = SDATA (str) + str_bytes;
2122 int i = 0;
2123 int *src, src_size;
2124
2125 if (endp - p == str_chars - consumed_chars)
2126 while (i < CCL_EXECUTE_BUF_SIZE && p < endp)
2127 source[i++] = *p++;
2128 else
2129 while (i < CCL_EXECUTE_BUF_SIZE && p < endp)
2130 source[i++] = STRING_CHAR_ADVANCE (p);
2131 consumed_chars += i;
2132 consumed_bytes = p - SDATA (str);
2133
2134 if (consumed_bytes == str_bytes)
2135 ccl.last_block = NILP (contin);
2136 src = source;
2137 src_size = i;
2138 while (1)
2139 {
2140 ccl_driver (&ccl, src, destination, src_size, CCL_EXECUTE_BUF_SIZE,
2141 Qnil);
2142 produced_chars += ccl.produced;
2143 if (NILP (unibyte_p))
2144 {
2145 if (outp - outbuf + MAX_MULTIBYTE_LENGTH * ccl.produced
2146 > outbufsize)
2147 {
2148 int offset = outp - outbuf;
2149 outbufsize += MAX_MULTIBYTE_LENGTH * ccl.produced;
2150 outbuf = (unsigned char *) xrealloc (outbuf, outbufsize);
2151 outp = outbuf + offset;
2152 }
2153 for (i = 0; i < ccl.produced; i++)
2154 CHAR_STRING_ADVANCE (destination[i], outp);
2155 }
2156 else
2157 {
2158 if (outp - outbuf + ccl.produced > outbufsize)
2159 {
2160 int offset = outp - outbuf;
2161 outbufsize += ccl.produced;
2162 outbuf = (unsigned char *) xrealloc (outbuf, outbufsize);
2163 outp = outbuf + offset;
2164 }
2165 for (i = 0; i < ccl.produced; i++)
2166 *outp++ = destination[i];
2167 }
2168 src += ccl.consumed;
2169 src_size -= ccl.consumed;
2170 if (ccl.status != CCL_STAT_SUSPEND_BY_DST)
2171 break;
2172 }
2173
2174 if (ccl.status != CCL_STAT_SUSPEND_BY_SRC
2175 || str_chars == consumed_chars)
2176 break;
2177 }
2178
2179 if (ccl.status == CCL_STAT_INVALID_CMD)
2180 error ("Error in CCL program at %dth code", ccl.ic);
2181 if (ccl.status == CCL_STAT_QUIT)
2182 error ("CCL program interrupted at %dth code", ccl.ic);
2183
2184 for (i = 0; i < 8; i++)
2185 ASET (status, i, make_number (ccl.reg[i]));
2186 ASET (status, 8, make_number (ccl.ic));
2187
2188 if (NILP (unibyte_p))
2189 val = make_multibyte_string ((char *) outbuf, produced_chars,
2190 outp - outbuf);
2191 else
2192 val = make_unibyte_string ((char *) outbuf, produced_chars);
2193 xfree (outbuf);
2194
2195 return val;
2196 }
2197
2198 DEFUN ("register-ccl-program", Fregister_ccl_program, Sregister_ccl_program,
2199 2, 2, 0,
2200 doc: /* Register CCL program CCL-PROG as NAME in `ccl-program-table'.
2201 CCL-PROG should be a compiled CCL program (vector), or nil.
2202 If it is nil, just reserve NAME as a CCL program name.
2203 Return index number of the registered CCL program. */)
2204 (name, ccl_prog)
2205 Lisp_Object name, ccl_prog;
2206 {
2207 int len = ASIZE (Vccl_program_table);
2208 int idx;
2209 Lisp_Object resolved;
2210
2211 CHECK_SYMBOL (name);
2212 resolved = Qnil;
2213 if (!NILP (ccl_prog))
2214 {
2215 CHECK_VECTOR (ccl_prog);
2216 resolved = resolve_symbol_ccl_program (ccl_prog);
2217 if (NILP (resolved))
2218 error ("Error in CCL program");
2219 if (VECTORP (resolved))
2220 {
2221 ccl_prog = resolved;
2222 resolved = Qt;
2223 }
2224 else
2225 resolved = Qnil;
2226 }
2227
2228 for (idx = 0; idx < len; idx++)
2229 {
2230 Lisp_Object slot;
2231
2232 slot = AREF (Vccl_program_table, idx);
2233 if (!VECTORP (slot))
2234 /* This is the first unsed slot. Register NAME here. */
2235 break;
2236
2237 if (EQ (name, AREF (slot, 0)))
2238 {
2239 /* Update this slot. */
2240 ASET (slot, 1, ccl_prog);
2241 ASET (slot, 2, resolved);
2242 ASET (slot, 3, Qt);
2243 return make_number (idx);
2244 }
2245 }
2246
2247 if (idx == len)
2248 /* Extend the table. */
2249 Vccl_program_table = larger_vector (Vccl_program_table, len * 2, Qnil);
2250
2251 {
2252 Lisp_Object elt;
2253
2254 elt = Fmake_vector (make_number (4), Qnil);
2255 ASET (elt, 0, name);
2256 ASET (elt, 1, ccl_prog);
2257 ASET (elt, 2, resolved);
2258 ASET (elt, 3, Qt);
2259 ASET (Vccl_program_table, idx, elt);
2260 }
2261
2262 Fput (name, Qccl_program_idx, make_number (idx));
2263 return make_number (idx);
2264 }
2265
2266 /* Register code conversion map.
2267 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
2268 The first element is the start code point.
2269 The other elements are mapped numbers.
2270 Symbol t means to map to an original number before mapping.
2271 Symbol nil means that the corresponding element is empty.
2272 Symbol lambda means to terminate mapping here.
2273 */
2274
2275 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map,
2276 Sregister_code_conversion_map,
2277 2, 2, 0,
2278 doc: /* Register SYMBOL as code conversion map MAP.
2279 Return index number of the registered map. */)
2280 (symbol, map)
2281 Lisp_Object symbol, map;
2282 {
2283 int len = ASIZE (Vcode_conversion_map_vector);
2284 int i;
2285 Lisp_Object index;
2286
2287 CHECK_SYMBOL (symbol);
2288 CHECK_VECTOR (map);
2289
2290 for (i = 0; i < len; i++)
2291 {
2292 Lisp_Object slot = AREF (Vcode_conversion_map_vector, i);
2293
2294 if (!CONSP (slot))
2295 break;
2296
2297 if (EQ (symbol, XCAR (slot)))
2298 {
2299 index = make_number (i);
2300 XSETCDR (slot, map);
2301 Fput (symbol, Qcode_conversion_map, map);
2302 Fput (symbol, Qcode_conversion_map_id, index);
2303 return index;
2304 }
2305 }
2306
2307 if (i == len)
2308 Vcode_conversion_map_vector = larger_vector (Vcode_conversion_map_vector,
2309 len * 2, Qnil);
2310
2311 index = make_number (i);
2312 Fput (symbol, Qcode_conversion_map, map);
2313 Fput (symbol, Qcode_conversion_map_id, index);
2314 ASET (Vcode_conversion_map_vector, i, Fcons (symbol, map));
2315 return index;
2316 }
2317
2318
2319 void
2320 syms_of_ccl ()
2321 {
2322 staticpro (&Vccl_program_table);
2323 Vccl_program_table = Fmake_vector (make_number (32), Qnil);
2324
2325 Qccl = intern ("ccl");
2326 staticpro (&Qccl);
2327
2328 Qcclp = intern ("cclp");
2329 staticpro (&Qcclp);
2330
2331 Qccl_program = intern ("ccl-program");
2332 staticpro (&Qccl_program);
2333
2334 Qccl_program_idx = intern ("ccl-program-idx");
2335 staticpro (&Qccl_program_idx);
2336
2337 Qcode_conversion_map = intern ("code-conversion-map");
2338 staticpro (&Qcode_conversion_map);
2339
2340 Qcode_conversion_map_id = intern ("code-conversion-map-id");
2341 staticpro (&Qcode_conversion_map_id);
2342
2343 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector,
2344 doc: /* Vector of code conversion maps. */);
2345 Vcode_conversion_map_vector = Fmake_vector (make_number (16), Qnil);
2346
2347 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist,
2348 doc: /* Alist of fontname patterns vs corresponding CCL program.
2349 Each element looks like (REGEXP . CCL-CODE),
2350 where CCL-CODE is a compiled CCL program.
2351 When a font whose name matches REGEXP is used for displaying a character,
2352 CCL-CODE is executed to calculate the code point in the font
2353 from the charset number and position code(s) of the character which are set
2354 in CCL registers R0, R1, and R2 before the execution.
2355 The code point in the font is set in CCL registers R1 and R2
2356 when the execution terminated.
2357 If the font is single-byte font, the register R2 is not used. */);
2358 Vfont_ccl_encoder_alist = Qnil;
2359
2360 DEFVAR_LISP ("translation-hash-table-vector", &Vtranslation_hash_table_vector,
2361 doc: /* Vector containing all translation hash tables ever defined.
2362 Comprises pairs (SYMBOL . TABLE) where SYMBOL and TABLE were set up by calls
2363 to `define-translation-hash-table'. The vector is indexed by the table id
2364 used by CCL. */);
2365 Vtranslation_hash_table_vector = Qnil;
2366
2367 defsubr (&Sccl_program_p);
2368 defsubr (&Sccl_execute);
2369 defsubr (&Sccl_execute_on_string);
2370 defsubr (&Sregister_ccl_program);
2371 defsubr (&Sregister_code_conversion_map);
2372 }
2373
2374 /* arch-tag: bb9a37be-68ce-4576-8d3d-15d750e4a860
2375 (do not change this comment) */
Emacs repository mirror