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