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