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