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