?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
(Rudimentary Changes): Remove doubled `to'.
[emacs.git] / src / ccl.c
blobfe7faafb9e5cc9076c118dbd64678c0f2c53dae5
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_Extension 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?. When the mapping
541 process reached to the end of the map set, it moves to the next
542 map set. If the next does not exit, the mapping process terminates,
543 and regard the last value as a result.
544
545 But, when VALm is mapped to VALn and VALn is not a number, the
546 mapping proceed as below:
547
548 If VALn is nil, the lastest map is ignored and the mapping of VALm
549 proceed to the next map.
550
551 In VALn is t, VALm is reverted to reg[rrr] and the mapping of VALm
552 proceed to the next map.
553
554 If VALn is lambda, move to the next map set like reaching to the
555 end of the current map set.
556
557 If VALn is a symbol, call the CCL program refered by it.
558 Then, use reg[rrr] as a mapped value except for -1, -2 and -3.
559 Such special values are regarded as nil, t, and lambda respectively.
560
561 Each map is a Lisp vector of the following format (a) or (b):
562 (a)......[STARTPOINT VAL1 VAL2 ...]
563 (b)......[t VAL STARTPOINT ENDPOINT],
564 where
565 STARTPOINT is an offset to be used for indexing a map,
566 ENDPOINT is a maximum index number of a map,
567 VAL and VALn is a number, nil, t, or lambda.
568
569 Valid index range of a map of type (a) is:
570 STARTPOINT <= index < STARTPOINT + map_size - 1
571 Valid index range of a map of type (b) is:
572 STARTPOINT <= index < ENDPOINT */
573
574 #define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
575 1:ExtendedCOMMNDXXXRRRrrrXXXXX
576 2:N-2
577 3:SEPARATOR_1 (< 0)
578 4:MAP-ID_1
579 5:MAP-ID_2
580 ...
581 M:SEPARATOR_x (< 0)
582 M+1:MAP-ID_y
583 ...
584 N:SEPARATOR_z (< 0)
585 */
586
587 #define MAX_MAP_SET_LEVEL 30
588
589 typedef struct
590 {
591 int rest_length;
592 int orig_val;
593 } tr_stack;
594
595 static tr_stack mapping_stack[MAX_MAP_SET_LEVEL];
596 static tr_stack *mapping_stack_pointer;
597
598 /* If this variable is non-zero, it indicates the stack_idx
599 of immediately called by CCL_MapMultiple. */
600 static int stack_idx_of_map_multiple;
601
602 #define PUSH_MAPPING_STACK(restlen, orig) \
603 do { \
604 mapping_stack_pointer->rest_length = (restlen); \
605 mapping_stack_pointer->orig_val = (orig); \
606 mapping_stack_pointer++; \
607 } while (0)
608
609 #define POP_MAPPING_STACK(restlen, orig) \
610 do { \
611 mapping_stack_pointer--; \
612 (restlen) = mapping_stack_pointer->rest_length; \
613 (orig) = mapping_stack_pointer->orig_val; \
614 } while (0)
615
616 #define CCL_CALL_FOR_MAP_INSTRUCTION(symbol, ret_ic) \
617 if (1) \
618 { \
619 struct ccl_program called_ccl; \
620 if (stack_idx >= 256 \
621 || (setup_ccl_program (&called_ccl, (symbol)) != 0)) \
622 { \
623 if (stack_idx > 0) \
624 { \
625 ccl_prog = ccl_prog_stack_struct[0].ccl_prog; \
626 ic = ccl_prog_stack_struct[0].ic; \
627 } \
628 CCL_INVALID_CMD; \
629 } \
630 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; \
631 ccl_prog_stack_struct[stack_idx].ic = (ret_ic); \
632 stack_idx++; \
633 ccl_prog = called_ccl.prog; \
634 ic = CCL_HEADER_MAIN; \
635 goto ccl_repeat; \
636 } \
637 else
638
639 #define CCL_MapSingle 0x12 /* Map by single code conversion map
640 1:ExtendedCOMMNDXXXRRRrrrXXXXX
641 2:MAP-ID
642 ------------------------------
643 Map reg[rrr] by MAP-ID.
644 If some valid mapping is found,
645 set reg[rrr] to the result,
646 else
647 set reg[RRR] to -1.
648 */
649
650 /* CCL arithmetic/logical operators. */
651 #define CCL_PLUS 0x00 /* X = Y + Z */
652 #define CCL_MINUS 0x01 /* X = Y - Z */
653 #define CCL_MUL 0x02 /* X = Y * Z */
654 #define CCL_DIV 0x03 /* X = Y / Z */
655 #define CCL_MOD 0x04 /* X = Y % Z */
656 #define CCL_AND 0x05 /* X = Y & Z */
657 #define CCL_OR 0x06 /* X = Y | Z */
658 #define CCL_XOR 0x07 /* X = Y ^ Z */
659 #define CCL_LSH 0x08 /* X = Y << Z */
660 #define CCL_RSH 0x09 /* X = Y >> Z */
661 #define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
662 #define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
663 #define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
664 #define CCL_LS 0x10 /* X = (X < Y) */
665 #define CCL_GT 0x11 /* X = (X > Y) */
666 #define CCL_EQ 0x12 /* X = (X == Y) */
667 #define CCL_LE 0x13 /* X = (X <= Y) */
668 #define CCL_GE 0x14 /* X = (X >= Y) */
669 #define CCL_NE 0x15 /* X = (X != Y) */
670
671 #define CCL_DECODE_SJIS 0x16 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
672 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
673 #define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z))
674 r[7] = LOWER_BYTE (SJIS (Y, Z) */
675
676 /* Terminate CCL program successfully. */
677 #define CCL_SUCCESS \
678 if (1) \
679 { \
680 ccl->status = CCL_STAT_SUCCESS; \
681 goto ccl_finish; \
682 } \
683 else
684
685 /* Suspend CCL program because of reading from empty input buffer or
686 writing to full output buffer. When this program is resumed, the
687 same I/O command is executed. */
688 #define CCL_SUSPEND(stat) \
689 if (1) \
690 { \
691 ic--; \
692 ccl->status = stat; \
693 goto ccl_finish; \
694 } \
695 else
696
697 /* Terminate CCL program because of invalid command. Should not occur
698 in the normal case. */
699 #define CCL_INVALID_CMD \
700 if (1) \
701 { \
702 ccl->status = CCL_STAT_INVALID_CMD; \
703 goto ccl_error_handler; \
704 } \
705 else
706
707 /* Encode one character CH to multibyte form and write to the current
708 output buffer. If CH is less than 256, CH is written as is. */
709 #define CCL_WRITE_CHAR(ch) \
710 do { \
711 int bytes = SINGLE_BYTE_CHAR_P (ch) ? 1: CHAR_BYTES (ch); \
712 if (!dst) \
713 CCL_INVALID_CMD; \
714 else if (dst + bytes + extra_bytes < (dst_bytes ? dst_end : src)) \
715 { \
716 if (bytes == 1) \
717 { \
718 *dst++ = (ch); \
719 if ((ch) >= 0x80 && (ch) < 0xA0) \
720 /* We may have to convert this eight-bit char to \
721 multibyte form later. */ \
722 extra_bytes++; \
723 } \
724 else if (CHAR_VALID_P (ch, 0)) \
725 dst += CHAR_STRING (ch, dst); \
726 else \
727 CCL_INVALID_CMD; \
728 } \
729 else \
730 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
731 } while (0)
732
733 /* Write a string at ccl_prog[IC] of length LEN to the current output
734 buffer. */
735 #define CCL_WRITE_STRING(len) \
736 do { \
737 if (!dst) \
738 CCL_INVALID_CMD; \
739 else if (dst + len <= (dst_bytes ? dst_end : src)) \
740 for (i = 0; i < len; i++) \
741 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
742 >> ((2 - (i % 3)) * 8)) & 0xFF; \
743 else \
744 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
745 } while (0)
746
747 /* Read one byte from the current input buffer into REGth register. */
748 #define CCL_READ_CHAR(REG) \
749 do { \
750 if (!src) \
751 CCL_INVALID_CMD; \
752 else if (src < src_end) \
753 { \
754 REG = *src++; \
755 if (REG == '\n' \
756 && ccl->eol_type != CODING_EOL_LF) \
757 { \
758 /* We are encoding. */ \
759 if (ccl->eol_type == CODING_EOL_CRLF) \
760 { \
761 if (ccl->cr_consumed) \
762 ccl->cr_consumed = 0; \
763 else \
764 { \
765 ccl->cr_consumed = 1; \
766 REG = '\r'; \
767 src--; \
768 } \
769 } \
770 else \
771 REG = '\r'; \
772 } \
773 if (REG == LEADING_CODE_8_BIT_CONTROL \
774 && ccl->multibyte) \
775 REG = *src++ - 0x20; \
776 } \
777 else if (ccl->last_block) \
778 { \
779 ic = ccl->eof_ic; \
780 goto ccl_repeat; \
781 } \
782 else \
783 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
784 } while (0)
785
786
787 /* Set C to the character code made from CHARSET and CODE. This is
788 like MAKE_CHAR but check the validity of CHARSET and CODE. If they
789 are not valid, set C to (CODE & 0xFF) because that is usually the
790 case that CCL_ReadMultibyteChar2 read an invalid code and it set
791 CODE to that invalid byte. */
792
793 #define CCL_MAKE_CHAR(charset, code, c) \
794 do { \
795 if (charset == CHARSET_ASCII) \
796 c = code & 0xFF; \
797 else if (CHARSET_DEFINED_P (charset) \
798 && (code & 0x7F) >= 32 \
799 && (code < 256 || ((code >> 7) & 0x7F) >= 32)) \
800 { \
801 int c1 = code & 0x7F, c2 = 0; \
802 \
803 if (code >= 256) \
804 c2 = c1, c1 = (code >> 7) & 0x7F; \
805 c = MAKE_CHAR (charset, c1, c2); \
806 } \
807 else \
808 c = code & 0xFF; \
809 } while (0)
810
811
812 /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
813 text goes to a place pointed by DESTINATION, the length of which
814 should not exceed DST_BYTES. The bytes actually processed is
815 returned as *CONSUMED. The return value is the length of the
816 resulting text. As a side effect, the contents of CCL registers
817 are updated. If SOURCE or DESTINATION is NULL, only operations on
818 registers are permitted. */
819
820 #ifdef CCL_DEBUG
821 #define CCL_DEBUG_BACKTRACE_LEN 256
822 int ccl_backtrace_table[CCL_BACKTRACE_TABLE];
823 int ccl_backtrace_idx;
824 #endif
825
826 struct ccl_prog_stack
827 {
828 Lisp_Object *ccl_prog; /* Pointer to an array of CCL code. */
829 int ic; /* Instruction Counter. */
830 };
831
832 /* For the moment, we only support depth 256 of stack. */
833 static struct ccl_prog_stack ccl_prog_stack_struct[256];
834
835 int
836 ccl_driver (ccl, source, destination, src_bytes, dst_bytes, consumed)
837 struct ccl_program *ccl;
838 unsigned char *source, *destination;
839 int src_bytes, dst_bytes;
840 int *consumed;
841 {
842 register int *reg = ccl->reg;
843 register int ic = ccl->ic;
844 register int code, field1, field2;
845 register Lisp_Object *ccl_prog = ccl->prog;
846 unsigned char *src = source, *src_end = src + src_bytes;
847 unsigned char *dst = destination, *dst_end = dst + dst_bytes;
848 int jump_address;
849 int i, j, op;
850 int stack_idx = ccl->stack_idx;
851 /* Instruction counter of the current CCL code. */
852 int this_ic;
853 /* CCL_WRITE_CHAR will produce 8-bit code of range 0x80..0x9F. But,
854 each of them will be converted to multibyte form of 2-byte
855 sequence. For that conversion, we remember how many more bytes
856 we must keep in DESTINATION in this variable. */
857 int extra_bytes = 0;
858
859 if (ic >= ccl->eof_ic)
860 ic = CCL_HEADER_MAIN;
861
862 if (ccl->buf_magnification ==0) /* We can't produce any bytes. */
863 dst = NULL;
864
865 /* Set mapping stack pointer. */
866 mapping_stack_pointer = mapping_stack;
867
868 #ifdef CCL_DEBUG
869 ccl_backtrace_idx = 0;
870 #endif
871
872 for (;;)
873 {
874 ccl_repeat:
875 #ifdef CCL_DEBUG
876 ccl_backtrace_table[ccl_backtrace_idx++] = ic;
877 if (ccl_backtrace_idx >= CCL_DEBUG_BACKTRACE_LEN)
878 ccl_backtrace_idx = 0;
879 ccl_backtrace_table[ccl_backtrace_idx] = 0;
880 #endif
881
882 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
883 {
884 /* We can't just signal Qquit, instead break the loop as if
885 the whole data is processed. Don't reset Vquit_flag, it
886 must be handled later at a safer place. */
887 if (consumed)
888 src = source + src_bytes;
889 ccl->status = CCL_STAT_QUIT;
890 break;
891 }
892
893 this_ic = ic;
894 code = XINT (ccl_prog[ic]); ic++;
895 field1 = code >> 8;
896 field2 = (code & 0xFF) >> 5;
897
898 #define rrr field2
899 #define RRR (field1 & 7)
900 #define Rrr ((field1 >> 3) & 7)
901 #define ADDR field1
902 #define EXCMD (field1 >> 6)
903
904 switch (code & 0x1F)
905 {
906 case CCL_SetRegister: /* 00000000000000000RRRrrrXXXXX */
907 reg[rrr] = reg[RRR];
908 break;
909
910 case CCL_SetShortConst: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
911 reg[rrr] = field1;
912 break;
913
914 case CCL_SetConst: /* 00000000000000000000rrrXXXXX */
915 reg[rrr] = XINT (ccl_prog[ic]);
916 ic++;
917 break;
918
919 case CCL_SetArray: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
920 i = reg[RRR];
921 j = field1 >> 3;
922 if ((unsigned int) i < j)
923 reg[rrr] = XINT (ccl_prog[ic + i]);
924 ic += j;
925 break;
926
927 case CCL_Jump: /* A--D--D--R--E--S--S-000XXXXX */
928 ic += ADDR;
929 break;
930
931 case CCL_JumpCond: /* A--D--D--R--E--S--S-rrrXXXXX */
932 if (!reg[rrr])
933 ic += ADDR;
934 break;
935
936 case CCL_WriteRegisterJump: /* A--D--D--R--E--S--S-rrrXXXXX */
937 i = reg[rrr];
938 CCL_WRITE_CHAR (i);
939 ic += ADDR;
940 break;
941
942 case CCL_WriteRegisterReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
943 i = reg[rrr];
944 CCL_WRITE_CHAR (i);
945 ic++;
946 CCL_READ_CHAR (reg[rrr]);
947 ic += ADDR - 1;
948 break;
949
950 case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */
951 i = XINT (ccl_prog[ic]);
952 CCL_WRITE_CHAR (i);
953 ic += ADDR;
954 break;
955
956 case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
957 i = XINT (ccl_prog[ic]);
958 CCL_WRITE_CHAR (i);
959 ic++;
960 CCL_READ_CHAR (reg[rrr]);
961 ic += ADDR - 1;
962 break;
963
964 case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */
965 j = XINT (ccl_prog[ic]);
966 ic++;
967 CCL_WRITE_STRING (j);
968 ic += ADDR - 1;
969 break;
970
971 case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
972 i = reg[rrr];
973 j = XINT (ccl_prog[ic]);
974 if ((unsigned int) i < j)
975 {
976 i = XINT (ccl_prog[ic + 1 + i]);
977 CCL_WRITE_CHAR (i);
978 }
979 ic += j + 2;
980 CCL_READ_CHAR (reg[rrr]);
981 ic += ADDR - (j + 2);
982 break;
983
984 case CCL_ReadJump: /* A--D--D--R--E--S--S-rrrYYYYY */
985 CCL_READ_CHAR (reg[rrr]);
986 ic += ADDR;
987 break;
988
989 case CCL_ReadBranch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
990 CCL_READ_CHAR (reg[rrr]);
991 /* fall through ... */
992 case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
993 if ((unsigned int) reg[rrr] < field1)
994 ic += XINT (ccl_prog[ic + reg[rrr]]);
995 else
996 ic += XINT (ccl_prog[ic + field1]);
997 break;
998
999 case CCL_ReadRegister: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
1000 while (1)
1001 {
1002 CCL_READ_CHAR (reg[rrr]);
1003 if (!field1) break;
1004 code = XINT (ccl_prog[ic]); ic++;
1005 field1 = code >> 8;
1006 field2 = (code & 0xFF) >> 5;
1007 }
1008 break;
1009
1010 case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */
1011 rrr = 7;
1012 i = reg[RRR];
1013 j = XINT (ccl_prog[ic]);
1014 op = field1 >> 6;
1015 jump_address = ic + 1;
1016 goto ccl_set_expr;
1017
1018 case CCL_WriteRegister: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
1019 while (1)
1020 {
1021 i = reg[rrr];
1022 CCL_WRITE_CHAR (i);
1023 if (!field1) break;
1024 code = XINT (ccl_prog[ic]); ic++;
1025 field1 = code >> 8;
1026 field2 = (code & 0xFF) >> 5;
1027 }
1028 break;
1029
1030 case CCL_WriteExprRegister: /* 1:00000OPERATIONRrrRRR000XXXXX */
1031 rrr = 7;
1032 i = reg[RRR];
1033 j = reg[Rrr];
1034 op = field1 >> 6;
1035 jump_address = ic;
1036 goto ccl_set_expr;
1037
1038 case CCL_Call: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
1039 {
1040 Lisp_Object slot;
1041 int prog_id;
1042
1043 /* If FFF is nonzero, the CCL program ID is in the
1044 following code. */
1045 if (rrr)
1046 {
1047 prog_id = XINT (ccl_prog[ic]);
1048 ic++;
1049 }
1050 else
1051 prog_id = field1;
1052
1053 if (stack_idx >= 256
1054 || prog_id < 0
1055 || prog_id >= XVECTOR (Vccl_program_table)->size
1056 || (slot = XVECTOR (Vccl_program_table)->contents[prog_id],
1057 !VECTORP (slot))
1058 || !VECTORP (XVECTOR (slot)->contents[1]))
1059 {
1060 if (stack_idx > 0)
1061 {
1062 ccl_prog = ccl_prog_stack_struct[0].ccl_prog;
1063 ic = ccl_prog_stack_struct[0].ic;
1064 }
1065 CCL_INVALID_CMD;
1066 }
1067
1068 ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog;
1069 ccl_prog_stack_struct[stack_idx].ic = ic;
1070 stack_idx++;
1071 ccl_prog = XVECTOR (XVECTOR (slot)->contents[1])->contents;
1072 ic = CCL_HEADER_MAIN;
1073 }
1074 break;
1075
1076 case CCL_WriteConstString: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1077 if (!rrr)
1078 CCL_WRITE_CHAR (field1);
1079 else
1080 {
1081 CCL_WRITE_STRING (field1);
1082 ic += (field1 + 2) / 3;
1083 }
1084 break;
1085
1086 case CCL_WriteArray: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
1087 i = reg[rrr];
1088 if ((unsigned int) i < field1)
1089 {
1090 j = XINT (ccl_prog[ic + i]);
1091 CCL_WRITE_CHAR (j);
1092 }
1093 ic += field1;
1094 break;
1095
1096 case CCL_End: /* 0000000000000000000000XXXXX */
1097 if (stack_idx > 0)
1098 {
1099 stack_idx--;
1100 ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog;
1101 ic = ccl_prog_stack_struct[stack_idx].ic;
1102 break;
1103 }
1104 if (src)
1105 src = src_end;
1106 /* ccl->ic should points to this command code again to
1107 suppress further processing. */
1108 ic--;
1109 CCL_SUCCESS;
1110
1111 case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */
1112 i = XINT (ccl_prog[ic]);
1113 ic++;
1114 op = field1 >> 6;
1115 goto ccl_expr_self;
1116
1117 case CCL_ExprSelfReg: /* 00000OPERATION000RRRrrrXXXXX */
1118 i = reg[RRR];
1119 op = field1 >> 6;
1120
1121 ccl_expr_self:
1122 switch (op)
1123 {
1124 case CCL_PLUS: reg[rrr] += i; break;
1125 case CCL_MINUS: reg[rrr] -= i; break;
1126 case CCL_MUL: reg[rrr] *= i; break;
1127 case CCL_DIV: reg[rrr] /= i; break;
1128 case CCL_MOD: reg[rrr] %= i; break;
1129 case CCL_AND: reg[rrr] &= i; break;
1130 case CCL_OR: reg[rrr] |= i; break;
1131 case CCL_XOR: reg[rrr] ^= i; break;
1132 case CCL_LSH: reg[rrr] <<= i; break;
1133 case CCL_RSH: reg[rrr] >>= i; break;
1134 case CCL_LSH8: reg[rrr] <<= 8; reg[rrr] |= i; break;
1135 case CCL_RSH8: reg[7] = reg[rrr] & 0xFF; reg[rrr] >>= 8; break;
1136 case CCL_DIVMOD: reg[7] = reg[rrr] % i; reg[rrr] /= i; break;
1137 case CCL_LS: reg[rrr] = reg[rrr] < i; break;
1138 case CCL_GT: reg[rrr] = reg[rrr] > i; break;
1139 case CCL_EQ: reg[rrr] = reg[rrr] == i; break;
1140 case CCL_LE: reg[rrr] = reg[rrr] <= i; break;
1141 case CCL_GE: reg[rrr] = reg[rrr] >= i; break;
1142 case CCL_NE: reg[rrr] = reg[rrr] != i; break;
1143 default: CCL_INVALID_CMD;
1144 }
1145 break;
1146
1147 case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */
1148 i = reg[RRR];
1149 j = XINT (ccl_prog[ic]);
1150 op = field1 >> 6;
1151 jump_address = ++ic;
1152 goto ccl_set_expr;
1153
1154 case CCL_SetExprReg: /* 00000OPERATIONRrrRRRrrrXXXXX */
1155 i = reg[RRR];
1156 j = reg[Rrr];
1157 op = field1 >> 6;
1158 jump_address = ic;
1159 goto ccl_set_expr;
1160
1161 case CCL_ReadJumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1162 CCL_READ_CHAR (reg[rrr]);
1163 case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
1164 i = reg[rrr];
1165 op = XINT (ccl_prog[ic]);
1166 jump_address = ic++ + ADDR;
1167 j = XINT (ccl_prog[ic]);
1168 ic++;
1169 rrr = 7;
1170 goto ccl_set_expr;
1171
1172 case CCL_ReadJumpCondExprReg: /* A--D--D--R--E--S--S-rrrXXXXX */
1173 CCL_READ_CHAR (reg[rrr]);
1174 case CCL_JumpCondExprReg:
1175 i = reg[rrr];
1176 op = XINT (ccl_prog[ic]);
1177 jump_address = ic++ + ADDR;
1178 j = reg[XINT (ccl_prog[ic])];
1179 ic++;
1180 rrr = 7;
1181
1182 ccl_set_expr:
1183 switch (op)
1184 {
1185 case CCL_PLUS: reg[rrr] = i + j; break;
1186 case CCL_MINUS: reg[rrr] = i - j; break;
1187 case CCL_MUL: reg[rrr] = i * j; break;
1188 case CCL_DIV: reg[rrr] = i / j; break;
1189 case CCL_MOD: reg[rrr] = i % j; break;
1190 case CCL_AND: reg[rrr] = i & j; break;
1191 case CCL_OR: reg[rrr] = i | j; break;
1192 case CCL_XOR: reg[rrr] = i ^ j;; break;
1193 case CCL_LSH: reg[rrr] = i << j; break;
1194 case CCL_RSH: reg[rrr] = i >> j; break;
1195 case CCL_LSH8: reg[rrr] = (i << 8) | j; break;
1196 case CCL_RSH8: reg[rrr] = i >> 8; reg[7] = i & 0xFF; break;
1197 case CCL_DIVMOD: reg[rrr] = i / j; reg[7] = i % j; break;
1198 case CCL_LS: reg[rrr] = i < j; break;
1199 case CCL_GT: reg[rrr] = i > j; break;
1200 case CCL_EQ: reg[rrr] = i == j; break;
1201 case CCL_LE: reg[rrr] = i <= j; break;
1202 case CCL_GE: reg[rrr] = i >= j; break;
1203 case CCL_NE: reg[rrr] = i != j; break;
1204 case CCL_DECODE_SJIS: DECODE_SJIS (i, j, reg[rrr], reg[7]); break;
1205 case CCL_ENCODE_SJIS: ENCODE_SJIS (i, j, reg[rrr], reg[7]); break;
1206 default: CCL_INVALID_CMD;
1207 }
1208 code &= 0x1F;
1209 if (code == CCL_WriteExprConst || code == CCL_WriteExprRegister)
1210 {
1211 i = reg[rrr];
1212 CCL_WRITE_CHAR (i);
1213 ic = jump_address;
1214 }
1215 else if (!reg[rrr])
1216 ic = jump_address;
1217 break;
1218
1219 case CCL_Extension:
1220 switch (EXCMD)
1221 {
1222 case CCL_ReadMultibyteChar2:
1223 if (!src)
1224 CCL_INVALID_CMD;
1225
1226 if (src >= src_end)
1227 {
1228 src++;
1229 goto ccl_read_multibyte_character_suspend;
1230 }
1231
1232 i = *src++;
1233 if (i == '\n' && ccl->eol_type != CODING_EOL_LF)
1234 {
1235 /* We are encoding. */
1236 if (ccl->eol_type == CODING_EOL_CRLF)
1237 {
1238 if (ccl->cr_consumed)
1239 ccl->cr_consumed = 0;
1240 else
1241 {
1242 ccl->cr_consumed = 1;
1243 i = '\r';
1244 src--;
1245 }
1246 }
1247 else
1248 i = '\r';
1249 reg[rrr] = i;
1250 reg[RRR] = CHARSET_ASCII;
1251 }
1252 else if (i < 0x80)
1253 {
1254 /* ASCII */
1255 reg[rrr] = i;
1256 reg[RRR] = CHARSET_ASCII;
1257 }
1258 else if (i <= MAX_CHARSET_OFFICIAL_DIMENSION2)
1259 {
1260 int dimension = BYTES_BY_CHAR_HEAD (i) - 1;
1261
1262 if (dimension == 0)
1263 {
1264 /* `i' is a leading code for an undefined charset. */
1265 reg[RRR] = CHARSET_8_BIT_GRAPHIC;
1266 reg[rrr] = i;
1267 }
1268 else if (src + dimension > src_end)
1269 goto ccl_read_multibyte_character_suspend;
1270 else
1271 {
1272 reg[RRR] = i;
1273 i = (*src++ & 0x7F);
1274 if (dimension == 1)
1275 reg[rrr] = i;
1276 else
1277 reg[rrr] = ((i << 7) | (*src++ & 0x7F));
1278 }
1279 }
1280 else if ((i == LEADING_CODE_PRIVATE_11)
1281 || (i == LEADING_CODE_PRIVATE_12))
1282 {
1283 if ((src + 1) >= src_end)
1284 goto ccl_read_multibyte_character_suspend;
1285 reg[RRR] = *src++;
1286 reg[rrr] = (*src++ & 0x7F);
1287 }
1288 else if ((i == LEADING_CODE_PRIVATE_21)
1289 || (i == LEADING_CODE_PRIVATE_22))
1290 {
1291 if ((src + 2) >= src_end)
1292 goto ccl_read_multibyte_character_suspend;
1293 reg[RRR] = *src++;
1294 i = (*src++ & 0x7F);
1295 reg[rrr] = ((i << 7) | (*src & 0x7F));
1296 src++;
1297 }
1298 else if (i == LEADING_CODE_8_BIT_CONTROL)
1299 {
1300 if (src >= src_end)
1301 goto ccl_read_multibyte_character_suspend;
1302 reg[RRR] = CHARSET_8_BIT_CONTROL;
1303 reg[rrr] = (*src++ - 0x20);
1304 }
1305 else if (i >= 0xA0)
1306 {
1307 reg[RRR] = CHARSET_8_BIT_GRAPHIC;
1308 reg[rrr] = i;
1309 }
1310 else
1311 {
1312 /* INVALID CODE. Return a single byte character. */
1313 reg[RRR] = CHARSET_ASCII;
1314 reg[rrr] = i;
1315 }
1316 break;
1317
1318 ccl_read_multibyte_character_suspend:
1319 src--;
1320 if (ccl->last_block)
1321 {
1322 ic = ccl->eof_ic;
1323 goto ccl_repeat;
1324 }
1325 else
1326 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC);
1327
1328 break;
1329
1330 case CCL_WriteMultibyteChar2:
1331 i = reg[RRR]; /* charset */
1332 if (i == CHARSET_ASCII
1333 || i == CHARSET_8_BIT_CONTROL
1334 || i == CHARSET_8_BIT_GRAPHIC)
1335 i = reg[rrr] & 0xFF;
1336 else if (CHARSET_DIMENSION (i) == 1)
1337 i = ((i - 0x70) << 7) | (reg[rrr] & 0x7F);
1338 else if (i < MIN_CHARSET_PRIVATE_DIMENSION2)
1339 i = ((i - 0x8F) << 14) | reg[rrr];
1340 else
1341 i = ((i - 0xE0) << 14) | reg[rrr];
1342
1343 CCL_WRITE_CHAR (i);
1344
1345 break;
1346
1347 case CCL_TranslateCharacter:
1348 CCL_MAKE_CHAR (reg[RRR], reg[rrr], i);
1349 op = translate_char (GET_TRANSLATION_TABLE (reg[Rrr]),
1350 i, -1, 0, 0);
1351 SPLIT_CHAR (op, reg[RRR], i, j);
1352 if (j != -1)
1353 i = (i << 7) | j;
1354
1355 reg[rrr] = i;
1356 break;
1357
1358 case CCL_TranslateCharacterConstTbl:
1359 op = XINT (ccl_prog[ic]); /* table */
1360 ic++;
1361 CCL_MAKE_CHAR (reg[RRR], reg[rrr], i);
1362 op = translate_char (GET_TRANSLATION_TABLE (op), i, -1, 0, 0);
1363 SPLIT_CHAR (op, reg[RRR], i, j);
1364 if (j != -1)
1365 i = (i << 7) | j;
1366
1367 reg[rrr] = i;
1368 break;
1369
1370 case CCL_IterateMultipleMap:
1371 {
1372 Lisp_Object map, content, attrib, value;
1373 int point, size, fin_ic;
1374
1375 j = XINT (ccl_prog[ic++]); /* number of maps. */
1376 fin_ic = ic + j;
1377 op = reg[rrr];
1378 if ((j > reg[RRR]) && (j >= 0))
1379 {
1380 ic += reg[RRR];
1381 i = reg[RRR];
1382 }
1383 else
1384 {
1385 reg[RRR] = -1;
1386 ic = fin_ic;
1387 break;
1388 }
1389
1390 for (;i < j;i++)
1391 {
1392
1393 size = XVECTOR (Vcode_conversion_map_vector)->size;
1394 point = XINT (ccl_prog[ic++]);
1395 if (point >= size) continue;
1396 map =
1397 XVECTOR (Vcode_conversion_map_vector)->contents[point];
1398
1399 /* Check map varidity. */
1400 if (!CONSP (map)) continue;
1401 map = XCDR (map);
1402 if (!VECTORP (map)) continue;
1403 size = XVECTOR (map)->size;
1404 if (size <= 1) continue;
1405
1406 content = XVECTOR (map)->contents[0];
1407
1408 /* check map type,
1409 [STARTPOINT VAL1 VAL2 ...] or
1410 [t ELELMENT STARTPOINT ENDPOINT] */
1411 if (NUMBERP (content))
1412 {
1413 point = XUINT (content);
1414 point = op - point + 1;
1415 if (!((point >= 1) && (point < size))) continue;
1416 content = XVECTOR (map)->contents[point];
1417 }
1418 else if (EQ (content, Qt))
1419 {
1420 if (size != 4) continue;
1421 if ((op >= XUINT (XVECTOR (map)->contents[2]))
1422 && (op < XUINT (XVECTOR (map)->contents[3])))
1423 content = XVECTOR (map)->contents[1];
1424 else
1425 continue;
1426 }
1427 else
1428 continue;
1429
1430 if (NILP (content))
1431 continue;
1432 else if (NUMBERP (content))
1433 {
1434 reg[RRR] = i;
1435 reg[rrr] = XINT(content);
1436 break;
1437 }
1438 else if (EQ (content, Qt) || EQ (content, Qlambda))
1439 {
1440 reg[RRR] = i;
1441 break;
1442 }
1443 else if (CONSP (content))
1444 {
1445 attrib = XCAR (content);
1446 value = XCDR (content);
1447 if (!NUMBERP (attrib) || !NUMBERP (value))
1448 continue;
1449 reg[RRR] = i;
1450 reg[rrr] = XUINT (value);
1451 break;
1452 }
1453 else if (SYMBOLP (content))
1454 CCL_CALL_FOR_MAP_INSTRUCTION (content, fin_ic);
1455 else
1456 CCL_INVALID_CMD;
1457 }
1458 if (i == j)
1459 reg[RRR] = -1;
1460 ic = fin_ic;
1461 }
1462 break;
1463
1464 case CCL_MapMultiple:
1465 {
1466 Lisp_Object map, content, attrib, value;
1467 int point, size, map_vector_size;
1468 int map_set_rest_length, fin_ic;
1469 int current_ic = this_ic;
1470
1471 /* inhibit recursive call on MapMultiple. */
1472 if (stack_idx_of_map_multiple > 0)
1473 {
1474 if (stack_idx_of_map_multiple <= stack_idx)
1475 {
1476 stack_idx_of_map_multiple = 0;
1477 mapping_stack_pointer = mapping_stack;
1478 CCL_INVALID_CMD;
1479 }
1480 }
1481 else
1482 mapping_stack_pointer = mapping_stack;
1483 stack_idx_of_map_multiple = 0;
1484
1485 map_set_rest_length =
1486 XINT (ccl_prog[ic++]); /* number of maps and separators. */
1487 fin_ic = ic + map_set_rest_length;
1488 op = reg[rrr];
1489
1490 if ((map_set_rest_length > reg[RRR]) && (reg[RRR] >= 0))
1491 {
1492 ic += reg[RRR];
1493 i = reg[RRR];
1494 map_set_rest_length -= i;
1495 }
1496 else
1497 {
1498 ic = fin_ic;
1499 reg[RRR] = -1;
1500 mapping_stack_pointer = mapping_stack;
1501 break;
1502 }
1503
1504 if (mapping_stack_pointer <= (mapping_stack + 1))
1505 {
1506 /* Set up initial state. */
1507 mapping_stack_pointer = mapping_stack;
1508 PUSH_MAPPING_STACK (0, op);
1509 reg[RRR] = -1;
1510 }
1511 else
1512 {
1513 /* Recover after calling other ccl program. */
1514 int orig_op;
1515
1516 POP_MAPPING_STACK (map_set_rest_length, orig_op);
1517 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1518 switch (op)
1519 {
1520 case -1:
1521 /* Regard it as Qnil. */
1522 op = orig_op;
1523 i++;
1524 ic++;
1525 map_set_rest_length--;
1526 break;
1527 case -2:
1528 /* Regard it as Qt. */
1529 op = reg[rrr];
1530 i++;
1531 ic++;
1532 map_set_rest_length--;
1533 break;
1534 case -3:
1535 /* Regard it as Qlambda. */
1536 op = orig_op;
1537 i += map_set_rest_length;
1538 ic += map_set_rest_length;
1539 map_set_rest_length = 0;
1540 break;
1541 default:
1542 /* Regard it as normal mapping. */
1543 i += map_set_rest_length;
1544 ic += map_set_rest_length;
1545 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1546 break;
1547 }
1548 }
1549 map_vector_size = XVECTOR (Vcode_conversion_map_vector)->size;
1550
1551 do {
1552 for (;map_set_rest_length > 0;i++, ic++, map_set_rest_length--)
1553 {
1554 point = XINT(ccl_prog[ic]);
1555 if (point < 0)
1556 {
1557 /* +1 is for including separator. */
1558 point = -point + 1;
1559 if (mapping_stack_pointer
1560 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1561 CCL_INVALID_CMD;
1562 PUSH_MAPPING_STACK (map_set_rest_length - point,
1563 reg[rrr]);
1564 map_set_rest_length = point;
1565 reg[rrr] = op;
1566 continue;
1567 }
1568
1569 if (point >= map_vector_size) continue;
1570 map = (XVECTOR (Vcode_conversion_map_vector)
1571 ->contents[point]);
1572
1573 /* Check map varidity. */
1574 if (!CONSP (map)) continue;
1575 map = XCDR (map);
1576 if (!VECTORP (map)) continue;
1577 size = XVECTOR (map)->size;
1578 if (size <= 1) continue;
1579
1580 content = XVECTOR (map)->contents[0];
1581
1582 /* check map type,
1583 [STARTPOINT VAL1 VAL2 ...] or
1584 [t ELEMENT STARTPOINT ENDPOINT] */
1585 if (NUMBERP (content))
1586 {
1587 point = XUINT (content);
1588 point = op - point + 1;
1589 if (!((point >= 1) && (point < size))) continue;
1590 content = XVECTOR (map)->contents[point];
1591 }
1592 else if (EQ (content, Qt))
1593 {
1594 if (size != 4) continue;
1595 if ((op >= XUINT (XVECTOR (map)->contents[2])) &&
1596 (op < XUINT (XVECTOR (map)->contents[3])))
1597 content = XVECTOR (map)->contents[1];
1598 else
1599 continue;
1600 }
1601 else
1602 continue;
1603
1604 if (NILP (content))
1605 continue;
1606
1607 reg[RRR] = i;
1608 if (NUMBERP (content))
1609 {
1610 op = XINT (content);
1611 i += map_set_rest_length - 1;
1612 ic += map_set_rest_length - 1;
1613 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1614 map_set_rest_length++;
1615 }
1616 else if (CONSP (content))
1617 {
1618 attrib = XCAR (content);
1619 value = XCDR (content);
1620 if (!NUMBERP (attrib) || !NUMBERP (value))
1621 continue;
1622 op = XUINT (value);
1623 i += map_set_rest_length - 1;
1624 ic += map_set_rest_length - 1;
1625 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1626 map_set_rest_length++;
1627 }
1628 else if (EQ (content, Qt))
1629 {
1630 op = reg[rrr];
1631 }
1632 else if (EQ (content, Qlambda))
1633 {
1634 i += map_set_rest_length;
1635 ic += map_set_rest_length;
1636 break;
1637 }
1638 else if (SYMBOLP (content))
1639 {
1640 if (mapping_stack_pointer
1641 >= &mapping_stack[MAX_MAP_SET_LEVEL])
1642 CCL_INVALID_CMD;
1643 PUSH_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1644 PUSH_MAPPING_STACK (map_set_rest_length, op);
1645 stack_idx_of_map_multiple = stack_idx + 1;
1646 CCL_CALL_FOR_MAP_INSTRUCTION (content, current_ic);
1647 }
1648 else
1649 CCL_INVALID_CMD;
1650 }
1651 if (mapping_stack_pointer <= (mapping_stack + 1))
1652 break;
1653 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1654 i += map_set_rest_length;
1655 ic += map_set_rest_length;
1656 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1657 } while (1);
1658
1659 ic = fin_ic;
1660 }
1661 reg[rrr] = op;
1662 break;
1663
1664 case CCL_MapSingle:
1665 {
1666 Lisp_Object map, attrib, value, content;
1667 int size, point;
1668 j = XINT (ccl_prog[ic++]); /* map_id */
1669 op = reg[rrr];
1670 if (j >= XVECTOR (Vcode_conversion_map_vector)->size)
1671 {
1672 reg[RRR] = -1;
1673 break;
1674 }
1675 map = XVECTOR (Vcode_conversion_map_vector)->contents[j];
1676 if (!CONSP (map))
1677 {
1678 reg[RRR] = -1;
1679 break;
1680 }
1681 map = XCDR (map);
1682 if (!VECTORP (map))
1683 {
1684 reg[RRR] = -1;
1685 break;
1686 }
1687 size = XVECTOR (map)->size;
1688 point = XUINT (XVECTOR (map)->contents[0]);
1689 point = op - point + 1;
1690 reg[RRR] = 0;
1691 if ((size <= 1) ||
1692 (!((point >= 1) && (point < size))))
1693 reg[RRR] = -1;
1694 else
1695 {
1696 reg[RRR] = 0;
1697 content = XVECTOR (map)->contents[point];
1698 if (NILP (content))
1699 reg[RRR] = -1;
1700 else if (NUMBERP (content))
1701 reg[rrr] = XINT (content);
1702 else if (EQ (content, Qt));
1703 else if (CONSP (content))
1704 {
1705 attrib = XCAR (content);
1706 value = XCDR (content);
1707 if (!NUMBERP (attrib) || !NUMBERP (value))
1708 continue;
1709 reg[rrr] = XUINT(value);
1710 break;
1711 }
1712 else if (SYMBOLP (content))
1713 CCL_CALL_FOR_MAP_INSTRUCTION (content, ic);
1714 else
1715 reg[RRR] = -1;
1716 }
1717 }
1718 break;
1719
1720 default:
1721 CCL_INVALID_CMD;
1722 }
1723 break;
1724
1725 default:
1726 CCL_INVALID_CMD;
1727 }
1728 }
1729
1730 ccl_error_handler:
1731 /* The suppress_error member is set when e.g. a CCL-based coding
1732 system is used for terminal output. */
1733 if (!ccl->suppress_error && destination)
1734 {
1735 /* We can insert an error message only if DESTINATION is
1736 specified and we still have a room to store the message
1737 there. */
1738 char msg[256];
1739 int msglen;
1740
1741 if (!dst)
1742 dst = destination;
1743
1744 switch (ccl->status)
1745 {
1746 case CCL_STAT_INVALID_CMD:
1747 sprintf(msg, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
1748 code & 0x1F, code, this_ic);
1749 #ifdef CCL_DEBUG
1750 {
1751 int i = ccl_backtrace_idx - 1;
1752 int j;
1753
1754 msglen = strlen (msg);
1755 if (dst + msglen <= (dst_bytes ? dst_end : src))
1756 {
1757 bcopy (msg, dst, msglen);
1758 dst += msglen;
1759 }
1760
1761 for (j = 0; j < CCL_DEBUG_BACKTRACE_LEN; j++, i--)
1762 {
1763 if (i < 0) i = CCL_DEBUG_BACKTRACE_LEN - 1;
1764 if (ccl_backtrace_table[i] == 0)
1765 break;
1766 sprintf(msg, " %d", ccl_backtrace_table[i]);
1767 msglen = strlen (msg);
1768 if (dst + msglen > (dst_bytes ? dst_end : src))
1769 break;
1770 bcopy (msg, dst, msglen);
1771 dst += msglen;
1772 }
1773 goto ccl_finish;
1774 }
1775 #endif
1776 break;
1777
1778 case CCL_STAT_QUIT:
1779 sprintf(msg, "\nCCL: Quited.");
1780 break;
1781
1782 default:
1783 sprintf(msg, "\nCCL: Unknown error type (%d).", ccl->status);
1784 }
1785
1786 msglen = strlen (msg);
1787 if (dst + msglen <= (dst_bytes ? dst_end : src))
1788 {
1789 bcopy (msg, dst, msglen);
1790 dst += msglen;
1791 }
1792 if (ccl->status == CCL_STAT_INVALID_CMD)
1793 {
1794 /* Copy the remaining source data. */
1795 int i = src_end - src;
1796 if (dst_bytes && (dst_end - dst) < i)
1797 i = dst_end - dst;
1798 bcopy (src, dst, i);
1799 src += i;
1800 dst += i;
1801 }
1802 }
1803
1804 ccl_finish:
1805 ccl->ic = ic;
1806 ccl->stack_idx = stack_idx;
1807 ccl->prog = ccl_prog;
1808 if (consumed) *consumed = src - source;
1809 return (dst ? dst - destination : 0);
1810 }
1811
1812 /* Resolve symbols in the specified CCL code (Lisp vector). This
1813 function converts symbols of code conversion maps and character
1814 translation tables embeded in the CCL code into their ID numbers.
1815
1816 The return value is a vector (CCL itself or a new vector in which
1817 all symbols are resolved), Qt if resolving of some symbol failed,
1818 or nil if CCL contains invalid data. */
1819
1820 static Lisp_Object
1821 resolve_symbol_ccl_program (ccl)
1822 Lisp_Object ccl;
1823 {
1824 int i, veclen, unresolved = 0;
1825 Lisp_Object result, contents, val;
1826
1827 result = ccl;
1828 veclen = XVECTOR (result)->size;
1829
1830 for (i = 0; i < veclen; i++)
1831 {
1832 contents = XVECTOR (result)->contents[i];
1833 if (INTEGERP (contents))
1834 continue;
1835 else if (CONSP (contents)
1836 && SYMBOLP (XCAR (contents))
1837 && SYMBOLP (XCDR (contents)))
1838 {
1839 /* This is the new style for embedding symbols. The form is
1840 (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
1841 an index number. */
1842
1843 if (EQ (result, ccl))
1844 result = Fcopy_sequence (ccl);
1845
1846 val = Fget (XCAR (contents), XCDR (contents));
1847 if (NATNUMP (val))
1848 XVECTOR (result)->contents[i] = val;
1849 else
1850 unresolved = 1;
1851 continue;
1852 }
1853 else if (SYMBOLP (contents))
1854 {
1855 /* This is the old style for embedding symbols. This style
1856 may lead to a bug if, for instance, a translation table
1857 and a code conversion map have the same name. */
1858 if (EQ (result, ccl))
1859 result = Fcopy_sequence (ccl);
1860
1861 val = Fget (contents, Qtranslation_table_id);
1862 if (NATNUMP (val))
1863 XVECTOR (result)->contents[i] = val;
1864 else
1865 {
1866 val = Fget (contents, Qcode_conversion_map_id);
1867 if (NATNUMP (val))
1868 XVECTOR (result)->contents[i] = val;
1869 else
1870 {
1871 val = Fget (contents, Qccl_program_idx);
1872 if (NATNUMP (val))
1873 XVECTOR (result)->contents[i] = val;
1874 else
1875 unresolved = 1;
1876 }
1877 }
1878 continue;
1879 }
1880 return Qnil;
1881 }
1882
1883 return (unresolved ? Qt : result);
1884 }
1885
1886 /* Return the compiled code (vector) of CCL program CCL_PROG.
1887 CCL_PROG is a name (symbol) of the program or already compiled
1888 code. If necessary, resolve symbols in the compiled code to index
1889 numbers. If we failed to get the compiled code or to resolve
1890 symbols, return Qnil. */
1891
1892 static Lisp_Object
1893 ccl_get_compiled_code (ccl_prog)
1894 Lisp_Object ccl_prog;
1895 {
1896 Lisp_Object val, slot;
1897
1898 if (VECTORP (ccl_prog))
1899 {
1900 val = resolve_symbol_ccl_program (ccl_prog);
1901 return (VECTORP (val) ? val : Qnil);
1902 }
1903 if (!SYMBOLP (ccl_prog))
1904 return Qnil;
1905
1906 val = Fget (ccl_prog, Qccl_program_idx);
1907 if (! NATNUMP (val)
1908 || XINT (val) >= XVECTOR (Vccl_program_table)->size)
1909 return Qnil;
1910 slot = XVECTOR (Vccl_program_table)->contents[XINT (val)];
1911 if (! VECTORP (slot)
1912 || XVECTOR (slot)->size != 3
1913 || ! VECTORP (XVECTOR (slot)->contents[1]))
1914 return Qnil;
1915 if (NILP (XVECTOR (slot)->contents[2]))
1916 {
1917 val = resolve_symbol_ccl_program (XVECTOR (slot)->contents[1]);
1918 if (! VECTORP (val))
1919 return Qnil;
1920 XVECTOR (slot)->contents[1] = val;
1921 XVECTOR (slot)->contents[2] = Qt;
1922 }
1923 return XVECTOR (slot)->contents[1];
1924 }
1925
1926 /* Setup fields of the structure pointed by CCL appropriately for the
1927 execution of CCL program CCL_PROG. CCL_PROG is the name (symbol)
1928 of the CCL program or the already compiled code (vector).
1929 Return 0 if we succeed this setup, else return -1.
1930
1931 If CCL_PROG is nil, we just reset the structure pointed by CCL. */
1932 int
1933 setup_ccl_program (ccl, ccl_prog)
1934 struct ccl_program *ccl;
1935 Lisp_Object ccl_prog;
1936 {
1937 int i;
1938
1939 if (! NILP (ccl_prog))
1940 {
1941 struct Lisp_Vector *vp;
1942
1943 ccl_prog = ccl_get_compiled_code (ccl_prog);
1944 if (! VECTORP (ccl_prog))
1945 return -1;
1946 vp = XVECTOR (ccl_prog);
1947 ccl->size = vp->size;
1948 ccl->prog = vp->contents;
1949 ccl->eof_ic = XINT (vp->contents[CCL_HEADER_EOF]);
1950 ccl->buf_magnification = XINT (vp->contents[CCL_HEADER_BUF_MAG]);
1951 }
1952 ccl->ic = CCL_HEADER_MAIN;
1953 for (i = 0; i < 8; i++)
1954 ccl->reg[i] = 0;
1955 ccl->last_block = 0;
1956 ccl->private_state = 0;
1957 ccl->status = 0;
1958 ccl->stack_idx = 0;
1959 ccl->eol_type = CODING_EOL_LF;
1960 ccl->suppress_error = 0;
1961 return 0;
1962 }
1963
1964 #ifdef emacs
1965
1966 DEFUN ("ccl-program-p", Fccl_program_p, Sccl_program_p, 1, 1, 0,
1967 "Return t if OBJECT is a CCL program name or a compiled CCL program code.\n\
1968 See the documentation of `define-ccl-program' for the detail of CCL program.")
1969 (object)
1970 Lisp_Object object;
1971 {
1972 Lisp_Object val;
1973
1974 if (VECTORP (object))
1975 {
1976 val = resolve_symbol_ccl_program (object);
1977 return (VECTORP (val) ? Qt : Qnil);
1978 }
1979 if (!SYMBOLP (object))
1980 return Qnil;
1981
1982 val = Fget (object, Qccl_program_idx);
1983 return ((! NATNUMP (val)
1984 || XINT (val) >= XVECTOR (Vccl_program_table)->size)
1985 ? Qnil : Qt);
1986 }
1987
1988 DEFUN ("ccl-execute", Fccl_execute, Sccl_execute, 2, 2, 0,
1989 "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
1990 \n\
1991 CCL-PROGRAM is a CCL program name (symbol)\n\
1992 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
1993 in this case, the overhead of the execution is bigger than the former case).\n\
1994 No I/O commands should appear in CCL-PROGRAM.\n\
1995 \n\
1996 REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
1997 of Nth register.\n\
1998 \n\
1999 As side effect, each element of REGISTERS holds the value of\n\
2000 corresponding register after the execution.\n\
2001 \n\
2002 See the documentation of `define-ccl-program' for the detail of CCL program.")
2003 (ccl_prog, reg)
2004 Lisp_Object ccl_prog, reg;
2005 {
2006 struct ccl_program ccl;
2007 int i;
2008
2009 if (setup_ccl_program (&ccl, ccl_prog) < 0)
2010 error ("Invalid CCL program");
2011
2012 CHECK_VECTOR (reg, 1);
2013 if (XVECTOR (reg)->size != 8)
2014 error ("Length of vector REGISTERS is not 8");
2015
2016 for (i = 0; i < 8; i++)
2017 ccl.reg[i] = (INTEGERP (XVECTOR (reg)->contents[i])
2018 ? XINT (XVECTOR (reg)->contents[i])
2019 : 0);
2020
2021 ccl_driver (&ccl, (unsigned char *)0, (unsigned char *)0, 0, 0, (int *)0);
2022 QUIT;
2023 if (ccl.status != CCL_STAT_SUCCESS)
2024 error ("Error in CCL program at %dth code", ccl.ic);
2025
2026 for (i = 0; i < 8; i++)
2027 XSETINT (XVECTOR (reg)->contents[i], ccl.reg[i]);
2028 return Qnil;
2029 }
2030
2031 DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, Sccl_execute_on_string,
2032 3, 5, 0,
2033 "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
2034 \n\
2035 CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
2036 or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
2037 in this case, the execution is slower).\n\
2038 \n\
2039 Read buffer is set to STRING, and write buffer is allocated automatically.\n\
2040 \n\
2041 STATUS is a vector of [R0 R1 ... R7 IC], where\n\
2042 R0..R7 are initial values of corresponding registers,\n\
2043 IC is the instruction counter specifying from where to start the program.\n\
2044 If R0..R7 are nil, they are initialized to 0.\n\
2045 If IC is nil, it is initialized to head of the CCL program.\n\
2046 \n\
2047 If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
2048 when read buffer is exausted, else, IC is always set to the end of\n\
2049 CCL-PROGRAM on exit.\n\
2050 \n\
2051 It returns the contents of write buffer as a string,\n\
2052 and as side effect, STATUS is updated.\n\
2053 If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
2054 is a unibyte string. By default it is a multibyte string.\n\
2055 \n\
2056 See the documentation of `define-ccl-program' for the detail of CCL program.")
2057 (ccl_prog, status, str, contin, unibyte_p)
2058 Lisp_Object ccl_prog, status, str, contin, unibyte_p;
2059 {
2060 Lisp_Object val;
2061 struct ccl_program ccl;
2062 int i, produced;
2063 int outbufsize;
2064 char *outbuf;
2065 struct gcpro gcpro1, gcpro2;
2066
2067 if (setup_ccl_program (&ccl, ccl_prog) < 0)
2068 error ("Invalid CCL program");
2069
2070 CHECK_VECTOR (status, 1);
2071 if (XVECTOR (status)->size != 9)
2072 error ("Length of vector STATUS is not 9");
2073 CHECK_STRING (str, 2);
2074
2075 GCPRO2 (status, str);
2076
2077 for (i = 0; i < 8; i++)
2078 {
2079 if (NILP (XVECTOR (status)->contents[i]))
2080 XSETINT (XVECTOR (status)->contents[i], 0);
2081 if (INTEGERP (XVECTOR (status)->contents[i]))
2082 ccl.reg[i] = XINT (XVECTOR (status)->contents[i]);
2083 }
2084 if (INTEGERP (XVECTOR (status)->contents[i]))
2085 {
2086 i = XFASTINT (XVECTOR (status)->contents[8]);
2087 if (ccl.ic < i && i < ccl.size)
2088 ccl.ic = i;
2089 }
2090 outbufsize = STRING_BYTES (XSTRING (str)) * ccl.buf_magnification + 256;
2091 outbuf = (char *) xmalloc (outbufsize);
2092 ccl.last_block = NILP (contin);
2093 ccl.multibyte = STRING_MULTIBYTE (str);
2094 produced = ccl_driver (&ccl, XSTRING (str)->data, outbuf,
2095 STRING_BYTES (XSTRING (str)), outbufsize, (int *) 0);
2096 for (i = 0; i < 8; i++)
2097 XSET (XVECTOR (status)->contents[i], Lisp_Int, ccl.reg[i]);
2098 XSETINT (XVECTOR (status)->contents[8], ccl.ic);
2099 UNGCPRO;
2100
2101 if (NILP (unibyte_p))
2102 {
2103 int nchars;
2104
2105 produced = str_as_multibyte (outbuf, outbufsize, produced, &nchars);
2106 val = make_multibyte_string (outbuf, nchars, produced);
2107 }
2108 else
2109 val = make_unibyte_string (outbuf, produced);
2110 xfree (outbuf);
2111 QUIT;
2112 if (ccl.status == CCL_STAT_SUSPEND_BY_DST)
2113 error ("Output buffer for the CCL programs overflow");
2114 if (ccl.status != CCL_STAT_SUCCESS
2115 && ccl.status != CCL_STAT_SUSPEND_BY_SRC)
2116 error ("Error in CCL program at %dth code", ccl.ic);
2117
2118 return val;
2119 }
2120
2121 DEFUN ("register-ccl-program", Fregister_ccl_program, Sregister_ccl_program,
2122 2, 2, 0,
2123 "Register CCL program CCL_PROG as NAME in `ccl-program-table'.\n\
2124 CCL_PROG should be a compiled CCL program (vector), or nil.\n\
2125 If it is nil, just reserve NAME as a CCL program name.\n\
2126 Return index number of the registered CCL program.")
2127 (name, ccl_prog)
2128 Lisp_Object name, ccl_prog;
2129 {
2130 int len = XVECTOR (Vccl_program_table)->size;
2131 int idx;
2132 Lisp_Object resolved;
2133
2134 CHECK_SYMBOL (name, 0);
2135 resolved = Qnil;
2136 if (!NILP (ccl_prog))
2137 {
2138 CHECK_VECTOR (ccl_prog, 1);
2139 resolved = resolve_symbol_ccl_program (ccl_prog);
2140 if (NILP (resolved))
2141 error ("Error in CCL program");
2142 if (VECTORP (resolved))
2143 {
2144 ccl_prog = resolved;
2145 resolved = Qt;
2146 }
2147 else
2148 resolved = Qnil;
2149 }
2150
2151 for (idx = 0; idx < len; idx++)
2152 {
2153 Lisp_Object slot;
2154
2155 slot = XVECTOR (Vccl_program_table)->contents[idx];
2156 if (!VECTORP (slot))
2157 /* This is the first unsed slot. Register NAME here. */
2158 break;
2159
2160 if (EQ (name, XVECTOR (slot)->contents[0]))
2161 {
2162 /* Update this slot. */
2163 XVECTOR (slot)->contents[1] = ccl_prog;
2164 XVECTOR (slot)->contents[2] = resolved;
2165 return make_number (idx);
2166 }
2167 }
2168
2169 if (idx == len)
2170 {
2171 /* Extend the table. */
2172 Lisp_Object new_table;
2173 int j;
2174
2175 new_table = Fmake_vector (make_number (len * 2), Qnil);
2176 for (j = 0; j < len; j++)
2177 XVECTOR (new_table)->contents[j]
2178 = XVECTOR (Vccl_program_table)->contents[j];
2179 Vccl_program_table = new_table;
2180 }
2181
2182 {
2183 Lisp_Object elt;
2184
2185 elt = Fmake_vector (make_number (3), Qnil);
2186 XVECTOR (elt)->contents[0] = name;
2187 XVECTOR (elt)->contents[1] = ccl_prog;
2188 XVECTOR (elt)->contents[2] = resolved;
2189 XVECTOR (Vccl_program_table)->contents[idx] = elt;
2190 }
2191
2192 Fput (name, Qccl_program_idx, make_number (idx));
2193 return make_number (idx);
2194 }
2195
2196 /* Register code conversion map.
2197 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
2198 The first element is start code point.
2199 The rest elements are mapped numbers.
2200 Symbol t means to map to an original number before mapping.
2201 Symbol nil means that the corresponding element is empty.
2202 Symbol lambda menas to terminate mapping here.
2203 */
2204
2205 DEFUN ("register-code-conversion-map", Fregister_code_conversion_map,
2206 Sregister_code_conversion_map,
2207 2, 2, 0,
2208 "Register SYMBOL as code conversion map MAP.\n\
2209 Return index number of the registered map.")
2210 (symbol, map)
2211 Lisp_Object symbol, map;
2212 {
2213 int len = XVECTOR (Vcode_conversion_map_vector)->size;
2214 int i;
2215 Lisp_Object index;
2216
2217 CHECK_SYMBOL (symbol, 0);
2218 CHECK_VECTOR (map, 1);
2219
2220 for (i = 0; i < len; i++)
2221 {
2222 Lisp_Object slot = XVECTOR (Vcode_conversion_map_vector)->contents[i];
2223
2224 if (!CONSP (slot))
2225 break;
2226
2227 if (EQ (symbol, XCAR (slot)))
2228 {
2229 index = make_number (i);
2230 XCDR (slot) = map;
2231 Fput (symbol, Qcode_conversion_map, map);
2232 Fput (symbol, Qcode_conversion_map_id, index);
2233 return index;
2234 }
2235 }
2236
2237 if (i == len)
2238 {
2239 Lisp_Object new_vector = Fmake_vector (make_number (len * 2), Qnil);
2240 int j;
2241
2242 for (j = 0; j < len; j++)
2243 XVECTOR (new_vector)->contents[j]
2244 = XVECTOR (Vcode_conversion_map_vector)->contents[j];
2245 Vcode_conversion_map_vector = new_vector;
2246 }
2247
2248 index = make_number (i);
2249 Fput (symbol, Qcode_conversion_map, map);
2250 Fput (symbol, Qcode_conversion_map_id, index);
2251 XVECTOR (Vcode_conversion_map_vector)->contents[i] = Fcons (symbol, map);
2252 return index;
2253 }
2254
2255
2256 void
2257 syms_of_ccl ()
2258 {
2259 staticpro (&Vccl_program_table);
2260 Vccl_program_table = Fmake_vector (make_number (32), Qnil);
2261
2262 Qccl_program = intern ("ccl-program");
2263 staticpro (&Qccl_program);
2264
2265 Qccl_program_idx = intern ("ccl-program-idx");
2266 staticpro (&Qccl_program_idx);
2267
2268 Qcode_conversion_map = intern ("code-conversion-map");
2269 staticpro (&Qcode_conversion_map);
2270
2271 Qcode_conversion_map_id = intern ("code-conversion-map-id");
2272 staticpro (&Qcode_conversion_map_id);
2273
2274 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector,
2275 "Vector of code conversion maps.");
2276 Vcode_conversion_map_vector = Fmake_vector (make_number (16), Qnil);
2277
2278 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist,
2279 "Alist of fontname patterns vs corresponding CCL program.\n\
2280 Each element looks like (REGEXP . CCL-CODE),\n\
2281 where CCL-CODE is a compiled CCL program.\n\
2282 When a font whose name matches REGEXP is used for displaying a character,\n\
2283 CCL-CODE is executed to calculate the code point in the font\n\
2284 from the charset number and position code(s) of the character which are set\n\
2285 in CCL registers R0, R1, and R2 before the execution.\n\
2286 The code point in the font is set in CCL registers R1 and R2\n\
2287 when the execution terminated.\n\
2288 If the font is single-byte font, the register R2 is not used.");
2289 Vfont_ccl_encoder_alist = Qnil;
2290
2291 defsubr (&Sccl_program_p);
2292 defsubr (&Sccl_execute);
2293 defsubr (&Sccl_execute_on_string);
2294 defsubr (&Sregister_ccl_program);
2295 defsubr (&Sregister_code_conversion_map);
2296 }
2297
2298 #endif /* emacs */
Emacs repository mirror