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