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