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