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