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