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