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