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