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