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