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