?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
(JIT Lock Mode): jit-lock-mode is not a command any more.
[emacs.git] / src / ccl.c
blob8e2ba81501e6143fa35ce49b2c4e91c5c9e05c2f
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 r = *src++; \
717 else if (ccl->last_block) \
718 { \
719 ic = ccl->eof_ic; \
720 goto ccl_repeat; \
721 } \
722 else \
723 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
724 } while (0)
725
726
727 /* Set C to the character code made from CHARSET and CODE. This is
728 like MAKE_CHAR but check the validity of CHARSET and CODE. If they
729 are not valid, set C to (CODE & 0xFF) because that is usually the
730 case that CCL_ReadMultibyteChar2 read an invalid code and it set
731 CODE to that invalid byte. */
732
733 #define CCL_MAKE_CHAR(charset, code, c) \
734 do { \
735 if (charset == CHARSET_ASCII) \
736 c = code & 0xFF; \
737 else if (CHARSET_DEFINED_P (charset) \
738 && (code & 0x7F) >= 32 \
739 && (code < 256 || ((code >> 7) & 0x7F) >= 32)) \
740 { \
741 int c1 = code & 0x7F, c2 = 0; \
742 \
743 if (code >= 256) \
744 c2 = c1, c1 = (code >> 7) & 0x7F; \
745 c = MAKE_CHAR (charset, c1, c2); \
746 } \
747 else \
748 c = code & 0xFF; \
749 } while (0)
750
751
752 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
753 text goes to a place pointed by DESTINATION, the length of which
754 should not exceed DST_BYTES. The bytes actually processed is
755 returned as *CONSUMED. The return value is the length of the
756 resulting text. As a side effect, the contents of CCL registers
757 are updated. If SOURCE or DESTINATION is NULL, only operations on
758 registers are permitted. */
759
760 #ifdef CCL_DEBUG
761 #define CCL_DEBUG_BACKTRACE_LEN 256
762 int ccl_backtrace_table[CCL_BACKTRACE_TABLE];
763 int ccl_backtrace_idx;
764 #endif
765
766 struct ccl_prog_stack
767 {
768 Lisp_Object *ccl_prog; /* Pointer to an array of CCL code. */
769 int ic; /* Instruction Counter. */
770 };
771
772 /* For the moment, we only support depth 256 of stack. */
773 static struct ccl_prog_stack ccl_prog_stack_struct[256];
774
775 int
776 ccl_driver (ccl, source, destination, src_bytes, dst_bytes, consumed)
777 struct ccl_program *ccl;
778 unsigned char *source, *destination;
779 int src_bytes, dst_bytes;
780 int *consumed;
781 {
782 register int *reg = ccl->reg;
783 register int ic = ccl->ic;
784 register int code, field1, field2;
785 register Lisp_Object *ccl_prog = ccl->prog;
786 unsigned char *src = source, *src_end = src + src_bytes;
787 unsigned char *dst = destination, *dst_end = dst + dst_bytes;
788 int jump_address;
789 int i, j, op;
790 int stack_idx = ccl->stack_idx;
791 /* Instruction counter of the current CCL code. */
792 int this_ic;
793
794 if (ic >= ccl->eof_ic)
795 ic = CCL_HEADER_MAIN;
796
797 if (ccl->buf_magnification ==0) /* We can't produce any bytes. */
798 dst = NULL;
799
800 #ifdef CCL_DEBUG
801 ccl_backtrace_idx = 0;
802 #endif
803
804 for (;;)
805 {
806 ccl_repeat:
807 #ifdef CCL_DEBUG
808 ccl_backtrace_table[ccl_backtrace_idx++] = ic;
809 if (ccl_backtrace_idx >= CCL_DEBUG_BACKTRACE_LEN)
810 ccl_backtrace_idx = 0;
811 ccl_backtrace_table[ccl_backtrace_idx] = 0;
812 #endif
813
814 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
815 {
816 /* We can't just signal Qquit, instead break the loop as if
817 the whole data is processed. Don't reset Vquit_flag, it
818 must be handled later at a safer place. */
819 if (consumed)
820 src = source + src_bytes;
821 ccl->status = CCL_STAT_QUIT;
822 break;
823 }
824
825 this_ic = ic;
826 code = XINT (ccl_prog[ic]); ic++;
827 field1 = code >> 8;
828 field2 = (code & 0xFF) >> 5;
829
830 #define rrr field2
831 #define RRR (field1 & 7)
832 #define Rrr ((field1 >> 3) & 7)
833 #define ADDR field1
834 #define EXCMD (field1 >> 6)
835
836 switch (code & 0x1F)
837 {
838 case CCL_SetRegister: /* 00000000000000000RRRrrrXXXXX */
839 reg[rrr] = reg[RRR];
840 break;
841
842 case CCL_SetShortConst: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
843 reg[rrr] = field1;
844 break;
845
846 case CCL_SetConst: /* 00000000000000000000rrrXXXXX */
847 reg[rrr] = XINT (ccl_prog[ic]);
848 ic++;
849 break;
850
851 case CCL_SetArray: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
852 i = reg[RRR];
853 j = field1 >> 3;
854 if ((unsigned int) i < j)
855 reg[rrr] = XINT (ccl_prog[ic + i]);
856 ic += j;
857 break;
858
859 case CCL_Jump: /* A--D--D--R--E--S--S-000XXXXX */
860 ic += ADDR;
861 break;
862
863 case CCL_JumpCond: /* A--D--D--R--E--S--S-rrrXXXXX */
864 if (!reg[rrr])
865 ic += ADDR;
866 break;
867
868 case CCL_WriteRegisterJump: /* A--D--D--R--E--S--S-rrrXXXXX */
869 i = reg[rrr];
870 CCL_WRITE_CHAR (i);
871 ic += ADDR;
872 break;
873
874 case CCL_WriteRegisterReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
875 i = reg[rrr];
876 CCL_WRITE_CHAR (i);
877 ic++;
878 CCL_READ_CHAR (reg[rrr]);
879 ic += ADDR - 1;
880 break;
881
882 case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */
883 i = XINT (ccl_prog[ic]);
884 CCL_WRITE_CHAR (i);
885 ic += ADDR;
886 break;
887
888 case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
889 i = XINT (ccl_prog[ic]);
890 CCL_WRITE_CHAR (i);
891 ic++;
892 CCL_READ_CHAR (reg[rrr]);
893 ic += ADDR - 1;
894 break;
895
896 case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */
897 j = XINT (ccl_prog[ic]);
898 ic++;
899 CCL_WRITE_STRING (j);
900 ic += ADDR - 1;
901 break;
902
903 case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
904 i = reg[rrr];
905 j = XINT (ccl_prog[ic]);
906 if ((unsigned int) i < j)
907 {
908 i = XINT (ccl_prog[ic + 1 + i]);
909 CCL_WRITE_CHAR (i);
910 }
911 ic += j + 2;
912 CCL_READ_CHAR (reg[rrr]);
913 ic += ADDR - (j + 2);
914 break;
915
916 case CCL_ReadJump: /* A--D--D--R--E--S--S-rrrYYYYY */
917 CCL_READ_CHAR (reg[rrr]);
918 ic += ADDR;
919 break;
920
921 case CCL_ReadBranch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
922 CCL_READ_CHAR (reg[rrr]);
923 /* fall through ... */
924 case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
925 if ((unsigned int) reg[rrr] < field1)
926 ic += XINT (ccl_prog[ic + reg[rrr]]);
927 else
928 ic += XINT (ccl_prog[ic + field1]);
929 break;
930
931 case CCL_ReadRegister: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
932 while (1)
933 {
934 CCL_READ_CHAR (reg[rrr]);
935 if (!field1) break;
936 code = XINT (ccl_prog[ic]); ic++;
937 field1 = code >> 8;
938 field2 = (code & 0xFF) >> 5;
939 }
940 break;
941
942 case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */
943 rrr = 7;
944 i = reg[RRR];
945 j = XINT (ccl_prog[ic]);
946 op = field1 >> 6;
947 jump_address = ic + 1;
948 goto ccl_set_expr;
949
950 case CCL_WriteRegister: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
951 while (1)
952 {
953 i = reg[rrr];
954 CCL_WRITE_CHAR (i);
955 if (!field1) break;
956 code = XINT (ccl_prog[ic]); ic++;
957 field1 = code >> 8;
958 field2 = (code & 0xFF) >> 5;
959 }
960 break;
961
962 case CCL_WriteExprRegister: /* 1:00000OPERATIONRrrRRR000XXXXX */
963 rrr = 7;
964 i = reg[RRR];
965 j = reg[Rrr];
966 op = field1 >> 6;
967 jump_address = ic;
968 goto ccl_set_expr;
969
970 case CCL_Call: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
971 {
972 Lisp_Object slot;
973 int prog_id;
974
975 /* If FFF is nonzero, the CCL program ID is in the
976 following code. */
977 if (rrr)
978 {
979 prog_id = XINT (ccl_prog[ic]);
980 ic++;
981 }
982 else
983 prog_id = field1;
984
985 if (stack_idx >= 256
986 || prog_id < 0
987 || prog_id >= XVECTOR (Vccl_program_table)->size
988 || (slot = XVECTOR (Vccl_program_table)->contents[prog_id],
989 !VECTORP (slot))
990 || !VECTORP (XVECTOR (slot)->contents[1]))
991 {
992 if (stack_idx > 0)
993 {
994 ccl_prog = ccl_prog_stack_struct[0].ccl_prog;
995 ic = ccl_prog_stack_struct[0].ic;
996 }
997 CCL_INVALID_CMD;
998 }
999
1000 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog;
1001 ccl_prog_stack_struct[stack_idx].ic = ic;
1002 stack_idx++;
1003 ccl_prog = XVECTOR (XVECTOR (slot)->contents[1])->contents;
1004 ic = CCL_HEADER_MAIN;
1005 }
1006 break;
1007
1008 case CCL_WriteConstString: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1009 if (!rrr)
1010 CCL_WRITE_CHAR (field1);
1011 else
1012 {
1013 CCL_WRITE_STRING (field1);
1014 ic += (field1 + 2) / 3;
1015 }
1016 break;
1017
1018 case CCL_WriteArray: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1019 i = reg[rrr];
1020 if ((unsigned int) i < field1)
1021 {
1022 j = XINT (ccl_prog[ic + i]);
1023 CCL_WRITE_CHAR (j);
1024 }
1025 ic += field1;
1026 break;
1027
1028 case CCL_End: /* 0000000000000000000000XXXXX */
1029 if (stack_idx-- > 0)
1030 {
1031 ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog;
1032 ic = ccl_prog_stack_struct[stack_idx].ic;
1033 break;
1034 }
1035 if (src)
1036 src = src_end;
1037 /* ccl->ic should points to this command code again to
1038 suppress further processing. */
1039 ic--;
1040 CCL_SUCCESS;
1041
1042 case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */
1043 i = XINT (ccl_prog[ic]);
1044 ic++;
1045 op = field1 >> 6;
1046 goto ccl_expr_self;
1047
1048 case CCL_ExprSelfReg: /* 00000OPERATION000RRRrrrXXXXX */
1049 i = reg[RRR];
1050 op = field1 >> 6;
1051
1052 ccl_expr_self:
1053 switch (op)
1054 {
1055 case CCL_PLUS: reg[rrr] += i; break;
1056 case CCL_MINUS: reg[rrr] -= i; break;
1057 case CCL_MUL: reg[rrr] *= i; break;
1058 case CCL_DIV: reg[rrr] /= i; break;
1059 case CCL_MOD: reg[rrr] %= i; break;
1060 case CCL_AND: reg[rrr] &= i; break;
1061 case CCL_OR: reg[rrr] |= i; break;
1062 case CCL_XOR: reg[rrr] ^= i; break;
1063 case CCL_LSH: reg[rrr] <<= i; break;
1064 case CCL_RSH: reg[rrr] >>= i; break;
1065 case CCL_LSH8: reg[rrr] <<= 8; reg[rrr] |= i; break;
1066 case CCL_RSH8: reg[7] = reg[rrr] & 0xFF; reg[rrr] >>= 8; break;
1067 case CCL_DIVMOD: reg[7] = reg[rrr] % i; reg[rrr] /= i; break;
1068 case CCL_LS: reg[rrr] = reg[rrr] < i; break;
1069 case CCL_GT: reg[rrr] = reg[rrr] > i; break;
1070 case CCL_EQ: reg[rrr] = reg[rrr] == i; break;
1071 case CCL_LE: reg[rrr] = reg[rrr] <= i; break;
1072 case CCL_GE: reg[rrr] = reg[rrr] >= i; break;
1073 case CCL_NE: reg[rrr] = reg[rrr] != i; break;
1074 default: CCL_INVALID_CMD;
1075 }
1076 break;
1077
1078 case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */
1079 i = reg[RRR];
1080 j = XINT (ccl_prog[ic]);
1081 op = field1 >> 6;
1082 jump_address = ++ic;
1083 goto ccl_set_expr;
1084
1085 case CCL_SetExprReg: /* 00000OPERATIONRrrRRRrrrXXXXX */
1086 i = reg[RRR];
1087 j = reg[Rrr];
1088 op = field1 >> 6;
1089 jump_address = ic;
1090 goto ccl_set_expr;
1091
1092 case CCL_ReadJumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1093 CCL_READ_CHAR (reg[rrr]);
1094 case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1095 i = reg[rrr];
1096 op = XINT (ccl_prog[ic]);
1097 jump_address = ic++ + ADDR;
1098 j = XINT (ccl_prog[ic]);
1099 ic++;
1100 rrr = 7;
1101 goto ccl_set_expr;
1102
1103 case CCL_ReadJumpCondExprReg: /* A--D--D--R--E--S--S-rrrXXXXX */
1104 CCL_READ_CHAR (reg[rrr]);
1105 case CCL_JumpCondExprReg:
1106 i = reg[rrr];
1107 op = XINT (ccl_prog[ic]);
1108 jump_address = ic++ + ADDR;
1109 j = reg[XINT (ccl_prog[ic])];
1110 ic++;
1111 rrr = 7;
1112
1113 ccl_set_expr:
1114 switch (op)
1115 {
1116 case CCL_PLUS: reg[rrr] = i + j; break;
1117 case CCL_MINUS: reg[rrr] = i - j; break;
1118 case CCL_MUL: reg[rrr] = i * j; break;
1119 case CCL_DIV: reg[rrr] = i / j; break;
1120 case CCL_MOD: reg[rrr] = i % j; break;
1121 case CCL_AND: reg[rrr] = i & j; break;
1122 case CCL_OR: reg[rrr] = i | j; break;
1123 case CCL_XOR: reg[rrr] = i ^ j;; break;
1124 case CCL_LSH: reg[rrr] = i << j; break;
1125 case CCL_RSH: reg[rrr] = i >> j; break;
1126 case CCL_LSH8: reg[rrr] = (i << 8) | j; break;
1127 case CCL_RSH8: reg[rrr] = i >> 8; reg[7] = i & 0xFF; break;
1128 case CCL_DIVMOD: reg[rrr] = i / j; reg[7] = i % j; break;
1129 case CCL_LS: reg[rrr] = i < j; break;
1130 case CCL_GT: reg[rrr] = i > j; break;
1131 case CCL_EQ: reg[rrr] = i == j; break;
1132 case CCL_LE: reg[rrr] = i <= j; break;
1133 case CCL_GE: reg[rrr] = i >= j; break;
1134 case CCL_NE: reg[rrr] = i != j; break;
1135 case CCL_DECODE_SJIS: DECODE_SJIS (i, j, reg[rrr], reg[7]); break;
1136 case CCL_ENCODE_SJIS: ENCODE_SJIS (i, j, reg[rrr], reg[7]); break;
1137 default: CCL_INVALID_CMD;
1138 }
1139 code &= 0x1F;
1140 if (code == CCL_WriteExprConst || code == CCL_WriteExprRegister)
1141 {
1142 i = reg[rrr];
1143 CCL_WRITE_CHAR (i);
1144 ic = jump_address;
1145 }
1146 else if (!reg[rrr])
1147 ic = jump_address;
1148 break;
1149
1150 case CCL_Extention:
1151 switch (EXCMD)
1152 {
1153 case CCL_ReadMultibyteChar2:
1154 if (!src)
1155 CCL_INVALID_CMD;
1156
1157 do {
1158 if (src >= src_end)
1159 {
1160 src++;
1161 goto ccl_read_multibyte_character_suspend;
1162 }
1163
1164 i = *src++;
1165 if (i < 0x80)
1166 {
1167 /* ASCII */
1168 reg[rrr] = i;
1169 reg[RRR] = CHARSET_ASCII;
1170 }
1171 else if (i <= MAX_CHARSET_OFFICIAL_DIMENSION1)
1172 {
1173 if (src >= src_end)
1174 goto ccl_read_multibyte_character_suspend;
1175 reg[RRR] = i;
1176 reg[rrr] = (*src++ & 0x7F);
1177 }
1178 else if (i <= MAX_CHARSET_OFFICIAL_DIMENSION2)
1179 {
1180 if ((src + 1) >= src_end)
1181 goto ccl_read_multibyte_character_suspend;
1182 reg[RRR] = i;
1183 i = (*src++ & 0x7F);
1184 reg[rrr] = ((i << 7) | (*src & 0x7F));
1185 src++;
1186 }
1187 else if ((i == LEADING_CODE_PRIVATE_11)
1188 || (i == LEADING_CODE_PRIVATE_12))
1189 {
1190 if ((src + 1) >= src_end)
1191 goto ccl_read_multibyte_character_suspend;
1192 reg[RRR] = *src++;
1193 reg[rrr] = (*src++ & 0x7F);
1194 }
1195 else if ((i == LEADING_CODE_PRIVATE_21)
1196 || (i == LEADING_CODE_PRIVATE_22))
1197 {
1198 if ((src + 2) >= src_end)
1199 goto ccl_read_multibyte_character_suspend;
1200 reg[RRR] = *src++;
1201 i = (*src++ & 0x7F);
1202 reg[rrr] = ((i << 7) | (*src & 0x7F));
1203 src++;
1204 }
1205 else if (i == LEADING_CODE_8_BIT_CONTROL)
1206 {
1207 if (src >= src_end)
1208 goto ccl_read_multibyte_character_suspend;
1209 reg[RRR] = CHARSET_8_BIT_CONTROL;
1210 reg[rrr] = (*src++ - 0x20);
1211 }
1212 else if (i >= 0xA0)
1213 {
1214 reg[RRR] = CHARSET_8_BIT_GRAPHIC;
1215 reg[rrr] = i;
1216 }
1217 else
1218 {
1219 /* INVALID CODE. Return a single byte character. */
1220 reg[RRR] = CHARSET_ASCII;
1221 reg[rrr] = i;
1222 }
1223 break;
1224 } while (1);
1225 break;
1226
1227 ccl_read_multibyte_character_suspend:
1228 src--;
1229 if (ccl->last_block)
1230 {
1231 ic = ccl->eof_ic;
1232 goto ccl_repeat;
1233 }
1234 else
1235 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC);
1236
1237 break;
1238
1239 case CCL_WriteMultibyteChar2:
1240 i = reg[RRR]; /* charset */
1241 if (i == CHARSET_ASCII
1242 || i == CHARSET_8_BIT_CONTROL
1243 || i == CHARSET_8_BIT_GRAPHIC)
1244 i = reg[rrr] & 0xFF;
1245 else if (CHARSET_DIMENSION (i) == 1)
1246 i = ((i - 0x70) << 7) | (reg[rrr] & 0x7F);
1247 else if (i < MIN_CHARSET_PRIVATE_DIMENSION2)
1248 i = ((i - 0x8F) << 14) | reg[rrr];
1249 else
1250 i = ((i - 0xE0) << 14) | reg[rrr];
1251
1252 CCL_WRITE_CHAR (i);
1253
1254 break;
1255
1256 case CCL_TranslateCharacter:
1257 CCL_MAKE_CHAR (reg[RRR], reg[rrr], i);
1258 op = translate_char (GET_TRANSLATION_TABLE (reg[Rrr]),
1259 i, -1, 0, 0);
1260 SPLIT_CHAR (op, reg[RRR], i, j);
1261 if (j != -1)
1262 i = (i << 7) | j;
1263
1264 reg[rrr] = i;
1265 break;
1266
1267 case CCL_TranslateCharacterConstTbl:
1268 op = XINT (ccl_prog[ic]); /* table */
1269 ic++;
1270 CCL_MAKE_CHAR (reg[RRR], reg[rrr], i);
1271 op = translate_char (GET_TRANSLATION_TABLE (op), i, -1, 0, 0);
1272 SPLIT_CHAR (op, reg[RRR], i, j);
1273 if (j != -1)
1274 i = (i << 7) | j;
1275
1276 reg[rrr] = i;
1277 break;
1278
1279 case CCL_IterateMultipleMap:
1280 {
1281 Lisp_Object map, content, attrib, value;
1282 int point, size, fin_ic;
1283
1284 j = XINT (ccl_prog[ic++]); /* number of maps. */
1285 fin_ic = ic + j;
1286 op = reg[rrr];
1287 if ((j > reg[RRR]) && (j >= 0))
1288 {
1289 ic += reg[RRR];
1290 i = reg[RRR];
1291 }
1292 else
1293 {
1294 reg[RRR] = -1;
1295 ic = fin_ic;
1296 break;
1297 }
1298
1299 for (;i < j;i++)
1300 {
1301
1302 size = XVECTOR (Vcode_conversion_map_vector)->size;
1303 point = XINT (ccl_prog[ic++]);
1304 if (point >= size) continue;
1305 map =
1306 XVECTOR (Vcode_conversion_map_vector)->contents[point];
1307
1308 /* Check map varidity. */
1309 if (!CONSP (map)) continue;
1310 map = XCDR (map);
1311 if (!VECTORP (map)) continue;
1312 size = XVECTOR (map)->size;
1313 if (size <= 1) continue;
1314
1315 content = XVECTOR (map)->contents[0];
1316
1317 /* check map type,
1318 [STARTPOINT VAL1 VAL2 ...] or
1319 [t ELELMENT STARTPOINT ENDPOINT] */
1320 if (NUMBERP (content))
1321 {
1322 point = XUINT (content);
1323 point = op - point + 1;
1324 if (!((point >= 1) && (point < size))) continue;
1325 content = XVECTOR (map)->contents[point];
1326 }
1327 else if (EQ (content, Qt))
1328 {
1329 if (size != 4) continue;
1330 if ((op >= XUINT (XVECTOR (map)->contents[2]))
1331 && (op < XUINT (XVECTOR (map)->contents[3])))
1332 content = XVECTOR (map)->contents[1];
1333 else
1334 continue;
1335 }
1336 else
1337 continue;
1338
1339 if (NILP (content))
1340 continue;
1341 else if (NUMBERP (content))
1342 {
1343 reg[RRR] = i;
1344 reg[rrr] = XINT(content);
1345 break;
1346 }
1347 else if (EQ (content, Qt) || EQ (content, Qlambda))
1348 {
1349 reg[RRR] = i;
1350 break;
1351 }
1352 else if (CONSP (content))
1353 {
1354 attrib = XCAR (content);
1355 value = XCDR (content);
1356 if (!NUMBERP (attrib) || !NUMBERP (value))
1357 continue;
1358 reg[RRR] = i;
1359 reg[rrr] = XUINT (value);
1360 break;
1361 }
1362 }
1363 if (i == j)
1364 reg[RRR] = -1;
1365 ic = fin_ic;
1366 }
1367 break;
1368
1369 case CCL_MapMultiple:
1370 {
1371 Lisp_Object map, content, attrib, value;
1372 int point, size, map_vector_size;
1373 int map_set_rest_length, fin_ic;
1374
1375 map_set_rest_length =
1376 XINT (ccl_prog[ic++]); /* number of maps and separators. */
1377 fin_ic = ic + map_set_rest_length;
1378 if ((map_set_rest_length > reg[RRR]) && (reg[RRR] >= 0))
1379 {
1380 ic += reg[RRR];
1381 i = reg[RRR];
1382 map_set_rest_length -= i;
1383 }
1384 else
1385 {
1386 ic = fin_ic;
1387 reg[RRR] = -1;
1388 break;
1389 }
1390 mapping_stack_pointer = mapping_stack;
1391 op = reg[rrr];
1392 PUSH_MAPPING_STACK (0, op);
1393 reg[RRR] = -1;
1394 map_vector_size = XVECTOR (Vcode_conversion_map_vector)->size;
1395 for (;map_set_rest_length > 0;i++, map_set_rest_length--)
1396 {
1397 point = XINT(ccl_prog[ic++]);
1398 if (point < 0)
1399 {
1400 point = -point;
1401 if (mapping_stack_pointer
1402 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1403 {
1404 CCL_INVALID_CMD;
1405 }
1406 PUSH_MAPPING_STACK (map_set_rest_length - point,
1407 reg[rrr]);
1408 map_set_rest_length = point + 1;
1409 reg[rrr] = op;
1410 continue;
1411 }
1412
1413 if (point >= map_vector_size) continue;
1414 map = (XVECTOR (Vcode_conversion_map_vector)
1415 ->contents[point]);
1416
1417 /* Check map varidity. */
1418 if (!CONSP (map)) continue;
1419 map = XCDR (map);
1420 if (!VECTORP (map)) continue;
1421 size = XVECTOR (map)->size;
1422 if (size <= 1) continue;
1423
1424 content = XVECTOR (map)->contents[0];
1425
1426 /* check map type,
1427 [STARTPOINT VAL1 VAL2 ...] or
1428 [t ELEMENT STARTPOINT ENDPOINT] */
1429 if (NUMBERP (content))
1430 {
1431 point = XUINT (content);
1432 point = op - point + 1;
1433 if (!((point >= 1) && (point < size))) continue;
1434 content = XVECTOR (map)->contents[point];
1435 }
1436 else if (EQ (content, Qt))
1437 {
1438 if (size != 4) continue;
1439 if ((op >= XUINT (XVECTOR (map)->contents[2])) &&
1440 (op < XUINT (XVECTOR (map)->contents[3])))
1441 content = XVECTOR (map)->contents[1];
1442 else
1443 continue;
1444 }
1445 else
1446 continue;
1447
1448 if (NILP (content))
1449 continue;
1450 else if (NUMBERP (content))
1451 {
1452 op = XINT (content);
1453 reg[RRR] = i;
1454 i += map_set_rest_length;
1455 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1456 }
1457 else if (CONSP (content))
1458 {
1459 attrib = XCAR (content);
1460 value = XCDR (content);
1461 if (!NUMBERP (attrib) || !NUMBERP (value))
1462 continue;
1463 reg[RRR] = i;
1464 op = XUINT (value);
1465 i += map_set_rest_length;
1466 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1467 }
1468 else if (EQ (content, Qt))
1469 {
1470 reg[RRR] = i;
1471 op = reg[rrr];
1472 i += map_set_rest_length;
1473 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1474 }
1475 else if (EQ (content, Qlambda))
1476 {
1477 reg[RRR] = i;
1478 break;
1479 }
1480 else
1481 CCL_INVALID_CMD;
1482 }
1483 ic = fin_ic;
1484 }
1485 reg[rrr] = op;
1486 break;
1487
1488 case CCL_MapSingle:
1489 {
1490 Lisp_Object map, attrib, value, content;
1491 int size, point;
1492 j = XINT (ccl_prog[ic++]); /* map_id */
1493 op = reg[rrr];
1494 if (j >= XVECTOR (Vcode_conversion_map_vector)->size)
1495 {
1496 reg[RRR] = -1;
1497 break;
1498 }
1499 map = XVECTOR (Vcode_conversion_map_vector)->contents[j];
1500 if (!CONSP (map))
1501 {
1502 reg[RRR] = -1;
1503 break;
1504 }
1505 map = XCDR (map);
1506 if (!VECTORP (map))
1507 {
1508 reg[RRR] = -1;
1509 break;
1510 }
1511 size = XVECTOR (map)->size;
1512 point = XUINT (XVECTOR (map)->contents[0]);
1513 point = op - point + 1;
1514 reg[RRR] = 0;
1515 if ((size <= 1) ||
1516 (!((point >= 1) && (point < size))))
1517 reg[RRR] = -1;
1518 else
1519 {
1520 reg[RRR] = 0;
1521 content = XVECTOR (map)->contents[point];
1522 if (NILP (content))
1523 reg[RRR] = -1;
1524 else if (NUMBERP (content))
1525 reg[rrr] = XINT (content);
1526 else if (EQ (content, Qt));
1527 else if (CONSP (content))
1528 {
1529 attrib = XCAR (content);
1530 value = XCDR (content);
1531 if (!NUMBERP (attrib) || !NUMBERP (value))
1532 continue;
1533 reg[rrr] = XUINT(value);
1534 break;
1535 }
1536 else
1537 reg[RRR] = -1;
1538 }
1539 }
1540 break;
1541
1542 default:
1543 CCL_INVALID_CMD;
1544 }
1545 break;
1546
1547 default:
1548 CCL_INVALID_CMD;
1549 }
1550 }
1551
1552 ccl_error_handler:
1553 if (destination)
1554 {
1555 /* We can insert an error message only if DESTINATION is
1556 specified and we still have a room to store the message
1557 there. */
1558 char msg[256];
1559 int msglen;
1560
1561 if (!dst)
1562 dst = destination;
1563
1564 switch (ccl->status)
1565 {
1566 case CCL_STAT_INVALID_CMD:
1567 sprintf(msg, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1568 code & 0x1F, code, this_ic);
1569 #ifdef CCL_DEBUG
1570 {
1571 int i = ccl_backtrace_idx - 1;
1572 int j;
1573
1574 msglen = strlen (msg);
1575 if (dst + msglen <= (dst_bytes ? dst_end : src))
1576 {
1577 bcopy (msg, dst, msglen);
1578 dst += msglen;
1579 }
1580
1581 for (j = 0; j < CCL_DEBUG_BACKTRACE_LEN; j++, i--)
1582 {
1583 if (i < 0) i = CCL_DEBUG_BACKTRACE_LEN - 1;
1584 if (ccl_backtrace_table[i] == 0)
1585 break;
1586 sprintf(msg, " %d", ccl_backtrace_table[i]);
1587 msglen = strlen (msg);
1588 if (dst + msglen > (dst_bytes ? dst_end : src))
1589 break;
1590 bcopy (msg, dst, msglen);
1591 dst += msglen;
1592 }
1593 goto ccl_finish;
1594 }
1595 #endif
1596 break;
1597
1598 case CCL_STAT_QUIT:
1599 sprintf(msg, "\nCCL: Quited.");
1600 break;
1601
1602 default:
1603 sprintf(msg, "\nCCL: Unknown error type (%d).", ccl->status);
1604 }
1605
1606 msglen = strlen (msg);
1607 if (dst + msglen <= (dst_bytes ? dst_end : src))
1608 {
1609 bcopy (msg, dst, msglen);
1610 dst += msglen;
1611 }
1612 }
1613
1614 ccl_finish:
1615 ccl->ic = ic;
1616 ccl->stack_idx = stack_idx;
1617 ccl->prog = ccl_prog;
1618 if (consumed) *consumed = src - source;
1619 return (dst ? dst - destination : 0);
1620 }
1621
1622 /* Resolve symbols in the specified CCL code (Lisp vector). This
1623 function converts symbols of code conversion maps and character
1624 translation tables embeded in the CCL code into their ID numbers.
1625
1626 The return value is a vector (CCL itself or a new vector in which
1627 all symbols are resolved), Qt if resolving of some symbol failed,
1628 or nil if CCL contains invalid data. */
1629
1630 static Lisp_Object
1631 resolve_symbol_ccl_program (ccl)
1632 Lisp_Object ccl;
1633 {
1634 int i, veclen, unresolved = 0;
1635 Lisp_Object result, contents, val;
1636
1637 result = ccl;
1638 veclen = XVECTOR (result)->size;
1639
1640 for (i = 0; i < veclen; i++)
1641 {
1642 contents = XVECTOR (result)->contents[i];
1643 if (INTEGERP (contents))
1644 continue;
1645 else if (CONSP (contents)
1646 && SYMBOLP (XCAR (contents))
1647 && SYMBOLP (XCDR (contents)))
1648 {
1649 /* This is the new style for embedding symbols. The form is
1650 (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
1651 an index number. */
1652
1653 if (EQ (result, ccl))
1654 result = Fcopy_sequence (ccl);
1655
1656 val = Fget (XCAR (contents), XCDR (contents));
1657 if (NATNUMP (val))
1658 XVECTOR (result)->contents[i] = val;
1659 else
1660 unresolved = 1;
1661 continue;
1662 }
1663 else if (SYMBOLP (contents))
1664 {
1665 /* This is the old style for embedding symbols. This style
1666 may lead to a bug if, for instance, a translation table
1667 and a code conversion map have the same name. */
1668 if (EQ (result, ccl))
1669 result = Fcopy_sequence (ccl);
1670
1671 val = Fget (contents, Qtranslation_table_id);
1672 if (NATNUMP (val))
1673 XVECTOR (result)->contents[i] = val;
1674 else
1675 {
1676 val = Fget (contents, Qcode_conversion_map_id);
1677 if (NATNUMP (val))
1678 XVECTOR (result)->contents[i] = val;
1679 else
1680 {
1681 val = Fget (contents, Qccl_program_idx);
1682 if (NATNUMP (val))
1683 XVECTOR (result)->contents[i] = val;
1684 else
1685 unresolved = 1;
1686 }
1687 }
1688 continue;
1689 }
1690 return Qnil;
1691 }
1692
1693 return (unresolved ? Qt : result);
1694 }
1695
1696 /* Return the compiled code (vector) of CCL program CCL_PROG.
1697 CCL_PROG is a name (symbol) of the program or already compiled
1698 code. If necessary, resolve symbols in the compiled code to index
1699 numbers. If we failed to get the compiled code or to resolve
1700 symbols, return Qnil. */
1701
1702 static Lisp_Object
1703 ccl_get_compiled_code (ccl_prog)
1704 Lisp_Object ccl_prog;
1705 {
1706 Lisp_Object val, slot;
1707
1708 if (VECTORP (ccl_prog))
1709 {
1710 val = resolve_symbol_ccl_program (ccl_prog);
1711 return (VECTORP (val) ? val : Qnil);
1712 }
1713 if (!SYMBOLP (ccl_prog))
1714 return Qnil;
1715
1716 val = Fget (ccl_prog, Qccl_program_idx);
1717 if (! NATNUMP (val)
1718 || XINT (val) >= XVECTOR (Vccl_program_table)->size)
1719 return Qnil;
1720 slot = XVECTOR (Vccl_program_table)->contents[XINT (val)];
1721 if (! VECTORP (slot)
1722 || XVECTOR (slot)->size != 3
1723 || ! VECTORP (XVECTOR (slot)->contents[1]))
1724 return Qnil;
1725 if (NILP (XVECTOR (slot)->contents[2]))
1726 {
1727 val = resolve_symbol_ccl_program (XVECTOR (slot)->contents[1]);
1728 if (! VECTORP (val))
1729 return Qnil;
1730 XVECTOR (slot)->contents[1] = val;
1731 XVECTOR (slot)->contents[2] = Qt;
1732 }
1733 return XVECTOR (slot)->contents[1];
1734 }
1735
1736 /* Setup fields of the structure pointed by CCL appropriately for the
1737 execution of CCL program CCL_PROG. CCL_PROG is the name (symbol)
1738 of the CCL program or the already compiled code (vector).
1739 Return 0 if we succeed this setup, else return -1.
1740
1741 If CCL_PROG is nil, we just reset the structure pointed by CCL. */
1742 int
1743 setup_ccl_program (ccl, ccl_prog)
1744 struct ccl_program *ccl;
1745 Lisp_Object ccl_prog;
1746 {
1747 int i;
1748
1749 if (! NILP (ccl_prog))
1750 {
1751 struct Lisp_Vector *vp;
1752
1753 ccl_prog = ccl_get_compiled_code (ccl_prog);
1754 if (! VECTORP (ccl_prog))
1755 return -1;
1756 vp = XVECTOR (ccl_prog);
1757 ccl->size = vp->size;
1758 ccl->prog = vp->contents;
1759 ccl->eof_ic = XINT (vp->contents[CCL_HEADER_EOF]);
1760 ccl->buf_magnification = XINT (vp->contents[CCL_HEADER_BUF_MAG]);
1761 }
1762 ccl->ic = CCL_HEADER_MAIN;
1763 for (i = 0; i < 8; i++)
1764 ccl->reg[i] = 0;
1765 ccl->last_block = 0;
1766 ccl->private_state = 0;
1767 ccl->status = 0;
1768 ccl->stack_idx = 0;
1769 ccl->eol_type = CODING_EOL_LF;
1770 return 0;
1771 }
1772
1773 #ifdef emacs
1774
1775 DEFUN ("ccl-program-p", Fccl_program_p, Sccl_program_p, 1, 1, 0,
1776 "Return t if OBJECT is a CCL program name or a compiled CCL program code.")
1777 (object)
1778 Lisp_Object object;
1779 {
1780 Lisp_Object val;
1781
1782 if (VECTORP (object))
1783 {
1784 val = resolve_symbol_ccl_program (object);
1785 return (VECTORP (val) ? Qt : Qnil);
1786 }
1787 if (!SYMBOLP (object))
1788 return Qnil;
1789
1790 val = Fget (object, Qccl_program_idx);
1791 return ((! NATNUMP (val)
1792 || XINT (val) >= XVECTOR (Vccl_program_table)->size)
1793 ? Qnil : Qt);
1794 }
1795
1796 DEFUN ("ccl-execute", Fccl_execute, Sccl_execute, 2, 2, 0,
1797 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1798 \n\
1799 CCL-PROGRAM is a CCL program name (symbol)\n\
1800 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1801 in this case, the overhead of the execution is bigger than the former case).\n\
1802 No I/O commands should appear in CCL-PROGRAM.\n\
1803 \n\
1804 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1805 of Nth register.\n\
1806 \n\
1807 As side effect, each element of REGISTERS holds the value of\n\
1808 corresponding register after the execution.")
1809 (ccl_prog, reg)
1810 Lisp_Object ccl_prog, reg;
1811 {
1812 struct ccl_program ccl;
1813 int i;
1814
1815 if (setup_ccl_program (&ccl, ccl_prog) < 0)
1816 error ("Invalid CCL program");
1817
1818 CHECK_VECTOR (reg, 1);
1819 if (XVECTOR (reg)->size != 8)
1820 error ("Length of vector REGISTERS is not 9");
1821
1822 for (i = 0; i < 8; i++)
1823 ccl.reg[i] = (INTEGERP (XVECTOR (reg)->contents[i])
1824 ? XINT (XVECTOR (reg)->contents[i])
1825 : 0);
1826
1827 ccl_driver (&ccl, (char *)0, (char *)0, 0, 0, (int *)0);
1828 QUIT;
1829 if (ccl.status != CCL_STAT_SUCCESS)
1830 error ("Error in CCL program at %dth code", ccl.ic);
1831
1832 for (i = 0; i < 8; i++)
1833 XSETINT (XVECTOR (reg)->contents[i], ccl.reg[i]);
1834 return Qnil;
1835 }
1836
1837 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, Sccl_execute_on_string,
1838 3, 5, 0,
1839 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
1840 \n\
1841 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
1842 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1843 in this case, the execution is slower).\n\
1844 \n\
1845 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
1846 \n\
1847 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
1848 R0..R7 are initial values of corresponding registers,\n\
1849 IC is the instruction counter specifying from where to start the program.\n\
1850 If R0..R7 are nil, they are initialized to 0.\n\
1851 If IC is nil, it is initialized to head of the CCL program.\n\
1852 \n\
1853 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
1854 when read buffer is exausted, else, IC is always set to the end of\n\
1855 CCL-PROGRAM on exit.\n\
1856 \n\
1857 It returns the contents of write buffer as a string,\n\
1858 and as side effect, STATUS is updated.\n\
1859 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
1860 is a unibyte string. By default it is a multibyte string.")
1861 (ccl_prog, status, str, contin, unibyte_p)
1862 Lisp_Object ccl_prog, status, str, contin, unibyte_p;
1863 {
1864 Lisp_Object val;
1865 struct ccl_program ccl;
1866 int i, produced;
1867 int outbufsize;
1868 char *outbuf;
1869 struct gcpro gcpro1, gcpro2;
1870
1871 if (setup_ccl_program (&ccl, ccl_prog) < 0)
1872 error ("Invalid CCL program");
1873
1874 CHECK_VECTOR (status, 1);
1875 if (XVECTOR (status)->size != 9)
1876 error ("Length of vector STATUS is not 9");
1877 CHECK_STRING (str, 2);
1878
1879 GCPRO2 (status, str);
1880
1881 for (i = 0; i < 8; i++)
1882 {
1883 if (NILP (XVECTOR (status)->contents[i]))
1884 XSETINT (XVECTOR (status)->contents[i], 0);
1885 if (INTEGERP (XVECTOR (status)->contents[i]))
1886 ccl.reg[i] = XINT (XVECTOR (status)->contents[i]);
1887 }
1888 if (INTEGERP (XVECTOR (status)->contents[i]))
1889 {
1890 i = XFASTINT (XVECTOR (status)->contents[8]);
1891 if (ccl.ic < i && i < ccl.size)
1892 ccl.ic = i;
1893 }
1894 outbufsize = STRING_BYTES (XSTRING (str)) * ccl.buf_magnification + 256;
1895 outbuf = (char *) xmalloc (outbufsize);
1896 if (!outbuf)
1897 error ("Not enough memory");
1898 ccl.last_block = NILP (contin);
1899 produced = ccl_driver (&ccl, XSTRING (str)->data, outbuf,
1900 STRING_BYTES (XSTRING (str)), outbufsize, (int *)0);
1901 for (i = 0; i < 8; i++)
1902 XSET (XVECTOR (status)->contents[i], Lisp_Int, ccl.reg[i]);
1903 XSETINT (XVECTOR (status)->contents[8], ccl.ic);
1904 UNGCPRO;
1905
1906 if (NILP (unibyte_p))
1907 val = make_string (outbuf, produced);
1908 else
1909 val = make_unibyte_string (outbuf, produced);
1910 free (outbuf);
1911 QUIT;
1912 if (ccl.status != CCL_STAT_SUCCESS
1913 && ccl.status != CCL_STAT_SUSPEND_BY_SRC
1914 && ccl.status != CCL_STAT_SUSPEND_BY_DST)
1915 error ("Error in CCL program at %dth code", ccl.ic);
1916
1917 return val;
1918 }
1919
1920 DEFUN ("register-ccl-program", Fregister_ccl_program, Sregister_ccl_program,
1921 2, 2, 0,
1922 "Register CCL program CCL_PROG as NAME in `ccl-program-table'.\n\
1923 CCL_PROG should be a compiled CCL program (vector), or nil.\n\
1924 If it is nil, just reserve NAME as a CCL program name.\n\
1925 Return index number of the registered CCL program.")
1926 (name, ccl_prog)
1927 Lisp_Object name, ccl_prog;
1928 {
1929 int len = XVECTOR (Vccl_program_table)->size;
1930 int idx;
1931 Lisp_Object resolved;
1932
1933 CHECK_SYMBOL (name, 0);
1934 resolved = Qnil;
1935 if (!NILP (ccl_prog))
1936 {
1937 CHECK_VECTOR (ccl_prog, 1);
1938 resolved = resolve_symbol_ccl_program (ccl_prog);
1939 if (! NILP (resolved))
1940 {
1941 ccl_prog = resolved;
1942 resolved = Qt;
1943 }
1944 }
1945
1946 for (idx = 0; idx < len; idx++)
1947 {
1948 Lisp_Object slot;
1949
1950 slot = XVECTOR (Vccl_program_table)->contents[idx];
1951 if (!VECTORP (slot))
1952 /* This is the first unsed slot. Register NAME here. */
1953 break;
1954
1955 if (EQ (name, XVECTOR (slot)->contents[0]))
1956 {
1957 /* Update this slot. */
1958 XVECTOR (slot)->contents[1] = ccl_prog;
1959 XVECTOR (slot)->contents[2] = resolved;
1960 return make_number (idx);
1961 }
1962 }
1963
1964 if (idx == len)
1965 {
1966 /* Extend the table. */
1967 Lisp_Object new_table;
1968 int j;
1969
1970 new_table = Fmake_vector (make_number (len * 2), Qnil);
1971 for (j = 0; j < len; j++)
1972 XVECTOR (new_table)->contents[j]
1973 = XVECTOR (Vccl_program_table)->contents[j];
1974 Vccl_program_table = new_table;
1975 }
1976
1977 {
1978 Lisp_Object elt;
1979
1980 elt = Fmake_vector (make_number (3), Qnil);
1981 XVECTOR (elt)->contents[0] = name;
1982 XVECTOR (elt)->contents[1] = ccl_prog;
1983 XVECTOR (elt)->contents[2] = resolved;
1984 XVECTOR (Vccl_program_table)->contents[idx] = elt;
1985 }
1986
1987 Fput (name, Qccl_program_idx, make_number (idx));
1988 return make_number (idx);
1989 }
1990
1991 /* Register code conversion map.
1992 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
1993 The first element is start code point.
1994 The rest elements are mapped numbers.
1995 Symbol t means to map to an original number before mapping.
1996 Symbol nil means that the corresponding element is empty.
1997 Symbol lambda menas to terminate mapping here.
1998 */
1999
2000 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map,
2001 Sregister_code_conversion_map,
2002 2, 2, 0,
2003 "Register SYMBOL as code conversion map MAP.\n\
2004 Return index number of the registered map.")
2005 (symbol, map)
2006 Lisp_Object symbol, map;
2007 {
2008 int len = XVECTOR (Vcode_conversion_map_vector)->size;
2009 int i;
2010 Lisp_Object index;
2011
2012 CHECK_SYMBOL (symbol, 0);
2013 CHECK_VECTOR (map, 1);
2014
2015 for (i = 0; i < len; i++)
2016 {
2017 Lisp_Object slot = XVECTOR (Vcode_conversion_map_vector)->contents[i];
2018
2019 if (!CONSP (slot))
2020 break;
2021
2022 if (EQ (symbol, XCAR (slot)))
2023 {
2024 index = make_number (i);
2025 XCDR (slot) = map;
2026 Fput (symbol, Qcode_conversion_map, map);
2027 Fput (symbol, Qcode_conversion_map_id, index);
2028 return index;
2029 }
2030 }
2031
2032 if (i == len)
2033 {
2034 Lisp_Object new_vector = Fmake_vector (make_number (len * 2), Qnil);
2035 int j;
2036
2037 for (j = 0; j < len; j++)
2038 XVECTOR (new_vector)->contents[j]
2039 = XVECTOR (Vcode_conversion_map_vector)->contents[j];
2040 Vcode_conversion_map_vector = new_vector;
2041 }
2042
2043 index = make_number (i);
2044 Fput (symbol, Qcode_conversion_map, map);
2045 Fput (symbol, Qcode_conversion_map_id, index);
2046 XVECTOR (Vcode_conversion_map_vector)->contents[i] = Fcons (symbol, map);
2047 return index;
2048 }
2049
2050
2051 void
2052 syms_of_ccl ()
2053 {
2054 staticpro (&Vccl_program_table);
2055 Vccl_program_table = Fmake_vector (make_number (32), Qnil);
2056
2057 Qccl_program = intern ("ccl-program");
2058 staticpro (&Qccl_program);
2059
2060 Qccl_program_idx = intern ("ccl-program-idx");
2061 staticpro (&Qccl_program_idx);
2062
2063 Qcode_conversion_map = intern ("code-conversion-map");
2064 staticpro (&Qcode_conversion_map);
2065
2066 Qcode_conversion_map_id = intern ("code-conversion-map-id");
2067 staticpro (&Qcode_conversion_map_id);
2068
2069 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector,
2070 "Vector of code conversion maps.");
2071 Vcode_conversion_map_vector = Fmake_vector (make_number (16), Qnil);
2072
2073 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist,
2074 "Alist of fontname patterns vs corresponding CCL program.\n\
2075 Each element looks like (REGEXP . CCL-CODE),\n\
2076 where CCL-CODE is a compiled CCL program.\n\
2077 When a font whose name matches REGEXP is used for displaying a character,\n\
2078 CCL-CODE is executed to calculate the code point in the font\n\
2079 from the charset number and position code(s) of the character which are set\n\
2080 in CCL registers R0, R1, and R2 before the execution.\n\
2081 The code point in the font is set in CCL registers R1 and R2\n\
2082 when the execution terminated.\n\
2083 If the font is single-byte font, the register R2 is not used.");
2084 Vfont_ccl_encoder_alist = Qnil;
2085
2086 defsubr (&Sccl_program_p);
2087 defsubr (&Sccl_execute);
2088 defsubr (&Sccl_execute_on_string);
2089 defsubr (&Sregister_ccl_program);
2090 defsubr (&Sregister_code_conversion_map);
2091 }
2092
2093 #endif /* emacs */
Emacs repository mirror