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