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