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