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