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