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