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