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