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