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