(define-charset): New args :min-code and :max-code.
[bpt/emacs.git] / src / ccl.c
CommitLineData
4ed46869 1/* CCL (Code Conversion Language) interpreter.
75c8c592 2 Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
41cd7d67 3 Copyright (C) 2001 Free Software Foundation, Inc.
75c8c592 4 Licensed to the Free Software Foundation.
c10842ea
KH
5 Copyright (C) 2001, 2002
6 National Institute of Advanced Industrial Science and Technology (AIST)
7 Registration Number H13PRO009
4ed46869 8
369314dc
KH
9This file is part of GNU Emacs.
10
11GNU Emacs is free software; you can redistribute it and/or modify
12it under the terms of the GNU General Public License as published by
13the Free Software Foundation; either version 2, or (at your option)
14any later version.
4ed46869 15
369314dc
KH
16GNU Emacs is distributed in the hope that it will be useful,
17but WITHOUT ANY WARRANTY; without even the implied warranty of
18MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19GNU General Public License for more details.
4ed46869 20
369314dc
KH
21You should have received a copy of the GNU General Public License
22along with GNU Emacs; see the file COPYING. If not, write to
23the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24Boston, MA 02111-1307, USA. */
4ed46869 25
4ed46869 26#ifdef emacs
4ed46869 27#include <config.h>
dfcf069d
AS
28#endif
29
68c45bf0
PE
30#include <stdio.h>
31
32#ifdef emacs
33
4ed46869 34#include "lisp.h"
c10842ea 35#include "character.h"
4ed46869
KH
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
c10842ea
KH
46Lisp_Object Qccl, Qcclp;
47
20398ea4 48/* This contains all code conversion map available to CCL. */
8146262a 49Lisp_Object Vcode_conversion_map_vector;
e34b1164 50
4ed46869
KH
51/* Alist of fontname patterns vs corresponding CCL program. */
52Lisp_Object Vfont_ccl_encoder_alist;
53
6ae21908
KH
54/* This symbol is a property which assocates with ccl program vector.
55 Ex: (get 'ccl-big5-encoder 'ccl-program) returns ccl program vector. */
e34b1164
KH
56Lisp_Object Qccl_program;
57
8146262a
KH
58/* These symbols are properties which associate with code conversion
59 map and their ID respectively. */
60Lisp_Object Qcode_conversion_map;
61Lisp_Object Qcode_conversion_map_id;
e34b1164 62
6ae21908
KH
63/* Symbols of ccl program have this property, a value of the property
64 is an index for Vccl_protram_table. */
65Lisp_Object Qccl_program_idx;
66
5232fa7b
KH
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. */
4ed46869
KH
72Lisp_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
887bfbd7 228 Nth code (YYYYY == CCL_ReadJump). */
4ed46869
KH
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
e34b1164 302#define CCL_Call 0x13 /* Call the CCL program whose ID is
5232fa7b
KH
303 CC..C or cc..c.
304 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX
305 [2:00000000cccccccccccccccccccc]
4ed46869 306 ------------------------------
5232fa7b
KH
307 if (FFF)
308 call (cc..c)
309 IC++;
310 else
311 call (CC..C)
4ed46869
KH
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
450ed226 430#define CCL_Extension 0x1F /* Extended CCL code
4ed46869
KH
431 1:ExtendedCOMMNDRrrRRRrrrXXXXX
432 2:ARGUEMENT
433 3:...
434 ------------------------------
435 extended_command (rrr,RRR,Rrr,ARGS)
436 */
437
e34b1164 438/*
6ae21908 439 Here after, Extended CCL Instructions.
e34b1164 440 Bit length of extended command is 14.
6ae21908 441 Therefore, the instruction code range is 0..16384(0x3fff).
e34b1164
KH
442 */
443
6ae21908
KH
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
8146262a 458/* Translate a character whose code point is reg[rrr] and the charset
f967223b 459 ID is reg[RRR] by a translation table whose ID is reg[Rrr].
6ae21908 460
8146262a 461 A translated character is set in reg[rrr] (code point) and reg[RRR]
6ae21908
KH
462 (charset ID). */
463
8146262a 464#define CCL_TranslateCharacter 0x02 /* Translate a multibyte character
6ae21908
KH
465 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
466
8146262a 467/* Translate a character whose code point is reg[rrr] and the charset
f967223b 468 ID is reg[RRR] by a translation table whose ID is ARGUMENT.
6ae21908 469
8146262a 470 A translated character is set in reg[rrr] (code point) and reg[RRR]
6ae21908
KH
471 (charset ID). */
472
8146262a
KH
473#define CCL_TranslateCharacterConstTbl 0x03 /* Translate a multibyte character
474 1:ExtendedCOMMNDRrrRRRrrrXXXXX
475 2:ARGUMENT(Translation Table ID)
476 */
6ae21908 477
8146262a
KH
478/* Iterate looking up MAPs for reg[rrr] starting from the Nth (N =
479 reg[RRR]) MAP until some value is found.
6ae21908 480
8146262a 481 Each MAP is a Lisp vector whose element is number, nil, t, or
6ae21908 482 lambda.
8146262a 483 If the element is nil, ignore the map and proceed to the next map.
6ae21908
KH
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
8146262a
KH
487 Detail of the map structure is descibed in the comment for
488 CCL_MapMultiple below. */
6ae21908 489
8146262a 490#define CCL_IterateMultipleMap 0x10 /* Iterate multiple maps
6ae21908 491 1:ExtendedCOMMNDXXXRRRrrrXXXXX
8146262a
KH
492 2:NUMBER of MAPs
493 3:MAP-ID1
494 4:MAP-ID2
6ae21908
KH
495 ...
496 */
497
8146262a
KH
498/* Map the code in reg[rrr] by MAPs starting from the Nth (N =
499 reg[RRR]) map.
6ae21908 500
9b27b20d 501 MAPs are supplied in the succeeding CCL codes as follows:
6ae21908 502
8146262a
KH
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)),
6ae21908 511 the compiled CCL codes has this sequence:
8146262a 512 CCL_MapMultiple (CCL code of this command)
9b27b20d
KH
513 16 (total number of MAPs and SEPARATORs)
514 -7 (1st SEPARATOR)
8146262a
KH
515 MAP-ID11
516 MAP-ID12
9b27b20d 517 -3 (2nd SEPARATOR)
8146262a
KH
518 MAP-ID121
519 MAP-ID122
520 MAP-ID123
521 MAP-ID13
9b27b20d 522 -7 (3rd SEPARATOR)
8146262a 523 MAP-ID21
9b27b20d 524 -4 (4th SEPARATOR)
8146262a 525 MAP-ID211
9b27b20d 526 -1 (5th SEPARATOR)
8146262a
KH
527 MAP_ID2111
528 MAP-ID212
529 MAP-ID22
6ae21908 530
9b27b20d 531 A value of each SEPARATOR follows this rule:
8146262a
KH
532 MAP-SET := SEPARATOR [(MAP-ID | MAP-SET)]+
533 SEPARATOR := -(number of MAP-IDs and SEPARATORs in the MAP-SET)
6ae21908 534
8146262a 535 (*)....Nest level of MAP-SET must not be over than MAX_MAP_SET_LEVEL.
6ae21908 536
8146262a
KH
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.
6ae21908 539
8146262a 540 The mapping is iterated for all maps in each map set (set of maps
9b27b20d
KH
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
54fa5bc1
KH
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.
9b27b20d
KH
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
54fa5bc1
KH
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.
6ae21908 567
8146262a 568 Each map is a Lisp vector of the following format (a) or (b):
6ae21908
KH
569 (a)......[STARTPOINT VAL1 VAL2 ...]
570 (b)......[t VAL STARTPOINT ENDPOINT],
571 where
8146262a 572 STARTPOINT is an offset to be used for indexing a map,
9b27b20d 573 ENDPOINT is a maximum index number of a map,
6ae21908
KH
574 VAL and VALn is a number, nil, t, or lambda.
575
8146262a
KH
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:
9b27b20d 579 STARTPOINT <= index < ENDPOINT */
6ae21908 580
8146262a 581#define CCL_MapMultiple 0x11 /* Mapping by multiple code conversion maps
6ae21908
KH
582 1:ExtendedCOMMNDXXXRRRrrrXXXXX
583 2:N-2
584 3:SEPARATOR_1 (< 0)
8146262a
KH
585 4:MAP-ID_1
586 5:MAP-ID_2
6ae21908
KH
587 ...
588 M:SEPARATOR_x (< 0)
8146262a 589 M+1:MAP-ID_y
6ae21908
KH
590 ...
591 N:SEPARATOR_z (< 0)
592 */
593
54fa5bc1 594#define MAX_MAP_SET_LEVEL 30
6ae21908
KH
595
596typedef struct
597{
598 int rest_length;
599 int orig_val;
600} tr_stack;
601
8146262a
KH
602static tr_stack mapping_stack[MAX_MAP_SET_LEVEL];
603static tr_stack *mapping_stack_pointer;
6ae21908 604
54fa5bc1
KH
605/* If this variable is non-zero, it indicates the stack_idx
606 of immediately called by CCL_MapMultiple. */
be57900b 607static int stack_idx_of_map_multiple;
54fa5bc1
KH
608
609#define PUSH_MAPPING_STACK(restlen, orig) \
a89f435d
PJ
610do \
611 { \
54fa5bc1
KH
612 mapping_stack_pointer->rest_length = (restlen); \
613 mapping_stack_pointer->orig_val = (orig); \
614 mapping_stack_pointer++; \
a89f435d
PJ
615 } \
616while (0)
54fa5bc1
KH
617
618#define POP_MAPPING_STACK(restlen, orig) \
a89f435d
PJ
619do \
620 { \
54fa5bc1
KH
621 mapping_stack_pointer--; \
622 (restlen) = mapping_stack_pointer->rest_length; \
623 (orig) = mapping_stack_pointer->orig_val; \
a89f435d
PJ
624 } \
625while (0)
6ae21908 626
54fa5bc1 627#define CCL_CALL_FOR_MAP_INSTRUCTION(symbol, ret_ic) \
a89f435d 628do \
0ee1088b 629 { \
54fa5bc1
KH
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; \
0ee1088b 647 } \
a89f435d 648while (0)
6ae21908 649
8146262a 650#define CCL_MapSingle 0x12 /* Map by single code conversion map
6ae21908 651 1:ExtendedCOMMNDXXXRRRrrrXXXXX
8146262a 652 2:MAP-ID
6ae21908 653 ------------------------------
8146262a
KH
654 Map reg[rrr] by MAP-ID.
655 If some valid mapping is found,
6ae21908
KH
656 set reg[rrr] to the result,
657 else
658 set reg[RRR] to -1.
659 */
4ed46869
KH
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
51520e8a 682#define CCL_DECODE_SJIS 0x16 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
4ed46869 683 r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
51520e8a
KH
684#define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z))
685 r[7] = LOWER_BYTE (SJIS (Y, Z) */
4ed46869 686
4ed46869 687/* Terminate CCL program successfully. */
0ee1088b 688#define CCL_SUCCESS \
a89f435d 689do \
0ee1088b 690 { \
4ed46869 691 ccl->status = CCL_STAT_SUCCESS; \
0ee1088b
KH
692 goto ccl_finish; \
693 } \
a89f435d 694while(0)
4ed46869
KH
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. */
e34b1164 699#define CCL_SUSPEND(stat) \
a89f435d 700do \
0ee1088b 701 { \
e34b1164
KH
702 ic--; \
703 ccl->status = stat; \
704 goto ccl_finish; \
0ee1088b 705 } \
a89f435d 706while (0)
4ed46869
KH
707
708/* Terminate CCL program because of invalid command. Should not occur
709 in the normal case. */
710#define CCL_INVALID_CMD \
a89f435d 711do \
0ee1088b 712 { \
4ed46869
KH
713 ccl->status = CCL_STAT_INVALID_CMD; \
714 goto ccl_error_handler; \
0ee1088b 715 } \
a89f435d 716while(0)
4ed46869
KH
717
718/* Encode one character CH to multibyte form and write to the current
887bfbd7 719 output buffer. If CH is less than 256, CH is written as is. */
c10842ea
KH
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); \
a8302ba3
KH
728 } while (0)
729
4ed46869
KH
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 { \
c10842ea 734 int i; \
4ed46869
KH
735 if (!dst) \
736 CCL_INVALID_CMD; \
c10842ea 737 else if (dst + len <= dst_end) \
4ed46869
KH
738 for (i = 0; i < len; i++) \
739 *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
740 >> ((2 - (i % 3)) * 8)) & 0xFF; \
741 else \
e34b1164 742 CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
4ed46869
KH
743 } while (0)
744
c10842ea
KH
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. */
4ed46869
KH
769
770#ifdef CCL_DEBUG
771#define CCL_DEBUG_BACKTRACE_LEN 256
772int ccl_backtrace_table[CCL_BACKTRACE_TABLE];
773int ccl_backtrace_idx;
774#endif
775
776struct ccl_prog_stack
777 {
a9f1cc19 778 Lisp_Object *ccl_prog; /* Pointer to an array of CCL code. */
4ed46869
KH
779 int ic; /* Instruction Counter. */
780 };
781
c13362d8
KH
782/* For the moment, we only support depth 256 of stack. */
783static struct ccl_prog_stack ccl_prog_stack_struct[256];
784
c10842ea
KH
785void
786ccl_driver (ccl, source, destination, src_size, dst_size)
4ed46869 787 struct ccl_program *ccl;
c10842ea
KH
788 int *source, *destination;
789 int src_size, dst_size;
4ed46869
KH
790{
791 register int *reg = ccl->reg;
792 register int ic = ccl->ic;
8a1ae4dd 793 register int code = 0, field1, field2;
e995085f 794 register Lisp_Object *ccl_prog = ccl->prog;
c10842ea
KH
795 int *src = source, *src_end = src + src_size;
796 int *dst = destination, *dst_end = dst + dst_size;
4ed46869 797 int jump_address;
8a1ae4dd 798 int i = 0, j, op;
c13362d8 799 int stack_idx = ccl->stack_idx;
519bf146 800 /* Instruction counter of the current CCL code. */
8a1ae4dd 801 int this_ic = 0;
c10842ea 802 struct charset *charset;
4ed46869
KH
803
804 if (ic >= ccl->eof_ic)
805 ic = CCL_HEADER_MAIN;
806
c10842ea 807 if (ccl->buf_magnification == 0) /* We can't read/produce any bytes. */
12abd7d1
KH
808 dst = NULL;
809
54fa5bc1
KH
810 /* Set mapping stack pointer. */
811 mapping_stack_pointer = mapping_stack;
812
4ed46869
KH
813#ifdef CCL_DEBUG
814 ccl_backtrace_idx = 0;
815#endif
816
817 for (;;)
818 {
4ccd0d4a 819 ccl_repeat:
4ed46869
KH
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. */
c10842ea
KH
832 if (src)
833 src = source + src_size;
4ed46869
KH
834 ccl->status = CCL_STAT_QUIT;
835 break;
836 }
837
519bf146 838 this_ic = ic;
4ed46869
KH
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
e34b1164 847#define EXCMD (field1 >> 6)
4ed46869
KH
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];
2e34157c 918 j = XINT (ccl_prog[ic]);
4ed46869
KH
919 if ((unsigned int) i < j)
920 {
887bfbd7 921 i = XINT (ccl_prog[ic + 1 + i]);
4ed46869
KH
922 CCL_WRITE_CHAR (i);
923 }
887bfbd7 924 ic += j + 2;
4ed46869
KH
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;
25660570 960 jump_address = ic + 1;
4ed46869
KH
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;
25660570 980 jump_address = ic;
4ed46869
KH
981 goto ccl_set_expr;
982
5232fa7b 983 case CCL_Call: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */
4ed46869
KH
984 {
985 Lisp_Object slot;
5232fa7b
KH
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;
4ed46869
KH
997
998 if (stack_idx >= 256
5232fa7b 999 || prog_id < 0
64ef2921
SM
1000 || prog_id >= ASIZE (Vccl_program_table)
1001 || (slot = AREF (Vccl_program_table, prog_id), !VECTORP (slot))
1002 || !VECTORP (AREF (slot, 1)))
4ed46869
KH
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++;
64ef2921 1015 ccl_prog = XVECTOR (AREF (slot, 1))->contents;
4ed46869
KH
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 */
d3a478e2 1041 if (stack_idx > 0)
4ed46869 1042 {
d3a478e2 1043 stack_idx--;
4ed46869
KH
1044 ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog;
1045 ic = ccl_prog_stack_struct[stack_idx].ic;
1046 break;
1047 }
ad3d1b1d
KH
1048 if (src)
1049 src = src_end;
1050 /* ccl->ic should points to this command code again to
1051 suppress further processing. */
1052 ic--;
4ed46869
KH
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;
c10842ea
KH
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 }
4ed46869
KH
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);
25660570 1171 ic = jump_address;
4ed46869
KH
1172 }
1173 else if (!reg[rrr])
1174 ic = jump_address;
1175 break;
1176
450ed226 1177 case CCL_Extension:
e34b1164
KH
1178 switch (EXCMD)
1179 {
6ae21908 1180 case CCL_ReadMultibyteChar2:
e34b1164
KH
1181 if (!src)
1182 CCL_INVALID_CMD;
c10842ea
KH
1183 CCL_READ_CHAR (i);
1184 charset = CHAR_CHARSET (i);
1185 reg[rrr] = CHARSET_ID (charset);
1186 reg[RRR] = ENCODE_CHAR (charset, i);
e34b1164
KH
1187 break;
1188
6ae21908 1189 case CCL_WriteMultibyteChar2:
c10842ea
KH
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);
e34b1164
KH
1195 break;
1196
8146262a 1197 case CCL_TranslateCharacter:
c10842ea
KH
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);
e34b1164
KH
1204 break;
1205
8146262a 1206 case CCL_TranslateCharacterConstTbl:
e34b1164
KH
1207 op = XINT (ccl_prog[ic]); /* table */
1208 ic++;
c10842ea
KH
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);
e34b1164
KH
1215 break;
1216
1217 case CCL_IterateMultipleMap:
1218 {
8146262a 1219 Lisp_Object map, content, attrib, value;
e34b1164
KH
1220 int point, size, fin_ic;
1221
8146262a 1222 j = XINT (ccl_prog[ic++]); /* number of maps. */
e34b1164
KH
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
64ef2921 1240 size = ASIZE (Vcode_conversion_map_vector);
d387866a 1241 point = XINT (ccl_prog[ic++]);
e34b1164 1242 if (point >= size) continue;
64ef2921 1243 map = AREF (Vcode_conversion_map_vector, point);
8146262a
KH
1244
1245 /* Check map varidity. */
1246 if (!CONSP (map)) continue;
03699b14 1247 map = XCDR (map);
8146262a 1248 if (!VECTORP (map)) continue;
64ef2921 1249 size = ASIZE (map);
e34b1164 1250 if (size <= 1) continue;
6ae21908 1251
64ef2921 1252 content = AREF (map, 0);
6ae21908 1253
8146262a 1254 /* check map type,
6ae21908
KH
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;
64ef2921 1262 content = AREF (map, point);
6ae21908
KH
1263 }
1264 else if (EQ (content, Qt))
1265 {
1266 if (size != 4) continue;
64ef2921
SM
1267 if ((op >= XUINT (AREF (map, 2)))
1268 && (op < XUINT (AREF (map, 3))))
1269 content = AREF (map, 1);
6ae21908
KH
1270 else
1271 continue;
1272 }
1273 else
1274 continue;
e34b1164
KH
1275
1276 if (NILP (content))
1277 continue;
1278 else if (NUMBERP (content))
1279 {
1280 reg[RRR] = i;
6ae21908 1281 reg[rrr] = XINT(content);
e34b1164
KH
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 {
03699b14
KR
1291 attrib = XCAR (content);
1292 value = XCDR (content);
e34b1164
KH
1293 if (!NUMBERP (attrib) || !NUMBERP (value))
1294 continue;
1295 reg[RRR] = i;
6ae21908 1296 reg[rrr] = XUINT (value);
e34b1164
KH
1297 break;
1298 }
54fa5bc1
KH
1299 else if (SYMBOLP (content))
1300 CCL_CALL_FOR_MAP_INSTRUCTION (content, fin_ic);
1301 else
1302 CCL_INVALID_CMD;
e34b1164
KH
1303 }
1304 if (i == j)
1305 reg[RRR] = -1;
1306 ic = fin_ic;
1307 }
1308 break;
1309
8146262a 1310 case CCL_MapMultiple:
e34b1164 1311 {
8146262a
KH
1312 Lisp_Object map, content, attrib, value;
1313 int point, size, map_vector_size;
1314 int map_set_rest_length, fin_ic;
54fa5bc1
KH
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;
8146262a
KH
1330
1331 map_set_rest_length =
1332 XINT (ccl_prog[ic++]); /* number of maps and separators. */
1333 fin_ic = ic + map_set_rest_length;
54fa5bc1
KH
1334 op = reg[rrr];
1335
8146262a 1336 if ((map_set_rest_length > reg[RRR]) && (reg[RRR] >= 0))
e34b1164
KH
1337 {
1338 ic += reg[RRR];
1339 i = reg[RRR];
8146262a 1340 map_set_rest_length -= i;
e34b1164
KH
1341 }
1342 else
1343 {
1344 ic = fin_ic;
1345 reg[RRR] = -1;
54fa5bc1 1346 mapping_stack_pointer = mapping_stack;
e34b1164
KH
1347 break;
1348 }
6ae21908 1349
54fa5bc1
KH
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;
e34b1164 1361
54fa5bc1
KH
1362 POP_MAPPING_STACK (map_set_rest_length, orig_op);
1363 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
1364 switch (op)
e34b1164 1365 {
54fa5bc1
KH
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. */
e34b1164 1375 op = reg[rrr];
54fa5bc1
KH
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. */
8146262a 1389 i += map_set_rest_length;
54fa5bc1 1390 ic += map_set_rest_length;
8146262a 1391 POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
6ae21908
KH
1392 break;
1393 }
e34b1164 1394 }
64ef2921 1395 map_vector_size = ASIZE (Vcode_conversion_map_vector);
54fa5bc1
KH
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;
64ef2921 1416 map = AREF (Vcode_conversion_map_vector, point);
54fa5bc1
KH
1417
1418 /* Check map varidity. */
1419 if (!CONSP (map)) continue;
1420 map = XCDR (map);
1421 if (!VECTORP (map)) continue;
64ef2921 1422 size = ASIZE (map);
54fa5bc1
KH
1423 if (size <= 1) continue;
1424
64ef2921 1425 content = AREF (map, 0);
54fa5bc1
KH
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;
64ef2921 1435 content = AREF (map, point);
54fa5bc1
KH
1436 }
1437 else if (EQ (content, Qt))
1438 {
1439 if (size != 4) continue;
64ef2921
SM
1440 if ((op >= XUINT (AREF (map, 2))) &&
1441 (op < XUINT (AREF (map, 3))))
1442 content = AREF (map, 1);
54fa5bc1
KH
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
e34b1164
KH
1504 ic = fin_ic;
1505 }
1506 reg[rrr] = op;
1507 break;
1508
8146262a 1509 case CCL_MapSingle:
e34b1164 1510 {
8146262a 1511 Lisp_Object map, attrib, value, content;
e34b1164 1512 int size, point;
8146262a 1513 j = XINT (ccl_prog[ic++]); /* map_id */
e34b1164 1514 op = reg[rrr];
64ef2921 1515 if (j >= ASIZE (Vcode_conversion_map_vector))
e34b1164
KH
1516 {
1517 reg[RRR] = -1;
1518 break;
1519 }
64ef2921 1520 map = AREF (Vcode_conversion_map_vector, j);
8146262a 1521 if (!CONSP (map))
e34b1164
KH
1522 {
1523 reg[RRR] = -1;
1524 break;
1525 }
03699b14 1526 map = XCDR (map);
8146262a 1527 if (!VECTORP (map))
e34b1164
KH
1528 {
1529 reg[RRR] = -1;
1530 break;
1531 }
64ef2921
SM
1532 size = ASIZE (map);
1533 point = XUINT (AREF (map, 0));
e34b1164
KH
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 {
b1cab202 1541 reg[RRR] = 0;
64ef2921 1542 content = AREF (map, point);
e34b1164
KH
1543 if (NILP (content))
1544 reg[RRR] = -1;
1545 else if (NUMBERP (content))
6ae21908 1546 reg[rrr] = XINT (content);
b1cab202 1547 else if (EQ (content, Qt));
e34b1164
KH
1548 else if (CONSP (content))
1549 {
03699b14
KR
1550 attrib = XCAR (content);
1551 value = XCDR (content);
e34b1164
KH
1552 if (!NUMBERP (attrib) || !NUMBERP (value))
1553 continue;
1554 reg[rrr] = XUINT(value);
1555 break;
1556 }
54fa5bc1
KH
1557 else if (SYMBOLP (content))
1558 CCL_CALL_FOR_MAP_INSTRUCTION (content, ic);
e34b1164
KH
1559 else
1560 reg[RRR] = -1;
1561 }
1562 }
1563 break;
1564
1565 default:
1566 CCL_INVALID_CMD;
1567 }
1568 break;
1569
4ed46869
KH
1570 default:
1571 CCL_INVALID_CMD;
1572 }
1573 }
1574
1575 ccl_error_handler:
0fb94c7f
EZ
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)
4ed46869
KH
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
12abd7d1
KH
1586 if (!dst)
1587 dst = destination;
1588
4ed46869
KH
1589 switch (ccl->status)
1590 {
1591 case CCL_STAT_INVALID_CMD:
1592 sprintf(msg, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
519bf146 1593 code & 0x1F, code, this_ic);
4ed46869
KH
1594#ifdef CCL_DEBUG
1595 {
1596 int i = ccl_backtrace_idx - 1;
1597 int j;
1598
1599 msglen = strlen (msg);
12abd7d1 1600 if (dst + msglen <= (dst_bytes ? dst_end : src))
4ed46869
KH
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);
12abd7d1 1613 if (dst + msglen > (dst_bytes ? dst_end : src))
4ed46869
KH
1614 break;
1615 bcopy (msg, dst, msglen);
1616 dst += msglen;
1617 }
12abd7d1 1618 goto ccl_finish;
4ed46869 1619 }
4ed46869 1620#endif
12abd7d1 1621 break;
4ed46869
KH
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);
c10842ea 1632 if (dst + msglen <= dst_end)
31165028 1633 {
c10842ea
KH
1634 for (i = 0; i < msglen; i++)
1635 *dst++ = msg[i];
31165028 1636 }
4ed46869
KH
1637 }
1638
1639 ccl_finish:
1640 ccl->ic = ic;
c13362d8
KH
1641 ccl->stack_idx = stack_idx;
1642 ccl->prog = ccl_prog;
c10842ea
KH
1643 ccl->consumed = src - source;
1644 ccl->produced = dst - destination;
4ed46869
KH
1645}
1646
5232fa7b
KH
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
1655static Lisp_Object
1656resolve_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;
64ef2921 1663 veclen = ASIZE (result);
5232fa7b
KH
1664
1665 for (i = 0; i < veclen; i++)
1666 {
64ef2921 1667 contents = AREF (result, i);
5232fa7b
KH
1668 if (INTEGERP (contents))
1669 continue;
1670 else if (CONSP (contents)
03699b14
KR
1671 && SYMBOLP (XCAR (contents))
1672 && SYMBOLP (XCDR (contents)))
5232fa7b
KH
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
03699b14 1681 val = Fget (XCAR (contents), XCDR (contents));
5232fa7b 1682 if (NATNUMP (val))
64ef2921 1683 AREF (result, i) = val;
5232fa7b
KH
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))
64ef2921 1698 AREF (result, i) = val;
5232fa7b
KH
1699 else
1700 {
1701 val = Fget (contents, Qcode_conversion_map_id);
1702 if (NATNUMP (val))
64ef2921 1703 AREF (result, i) = val;
5232fa7b
KH
1704 else
1705 {
1706 val = Fget (contents, Qccl_program_idx);
1707 if (NATNUMP (val))
64ef2921 1708 AREF (result, i) = val;
5232fa7b
KH
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
1727static Lisp_Object
1728ccl_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)
64ef2921 1743 || XINT (val) >= ASIZE (Vccl_program_table))
5232fa7b 1744 return Qnil;
64ef2921 1745 slot = AREF (Vccl_program_table, XINT (val));
5232fa7b 1746 if (! VECTORP (slot)
64ef2921
SM
1747 || ASIZE (slot) != 3
1748 || ! VECTORP (AREF (slot, 1)))
5232fa7b 1749 return Qnil;
64ef2921 1750 if (NILP (AREF (slot, 2)))
5232fa7b 1751 {
64ef2921 1752 val = resolve_symbol_ccl_program (AREF (slot, 1));
5232fa7b
KH
1753 if (! VECTORP (val))
1754 return Qnil;
64ef2921
SM
1755 AREF (slot, 1) = val;
1756 AREF (slot, 2) = Qt;
5232fa7b 1757 }
64ef2921 1758 return AREF (slot, 1);
5232fa7b
KH
1759}
1760
4ed46869 1761/* Setup fields of the structure pointed by CCL appropriately for the
5232fa7b
KH
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. */
1767int
1768setup_ccl_program (ccl, ccl_prog)
4ed46869 1769 struct ccl_program *ccl;
5232fa7b 1770 Lisp_Object ccl_prog;
4ed46869
KH
1771{
1772 int i;
1773
5232fa7b 1774 if (! NILP (ccl_prog))
ad3d1b1d 1775 {
5232fa7b 1776 struct Lisp_Vector *vp;
ad3d1b1d 1777
5232fa7b
KH
1778 ccl_prog = ccl_get_compiled_code (ccl_prog);
1779 if (! VECTORP (ccl_prog))
1780 return -1;
1781 vp = XVECTOR (ccl_prog);
ad3d1b1d
KH
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 }
4ed46869 1787 ccl->ic = CCL_HEADER_MAIN;
4ed46869
KH
1788 for (i = 0; i < 8; i++)
1789 ccl->reg[i] = 0;
1790 ccl->last_block = 0;
e34b1164 1791 ccl->private_state = 0;
4ed46869 1792 ccl->status = 0;
c13362d8 1793 ccl->stack_idx = 0;
ae08ba36 1794 ccl->suppress_error = 0;
5232fa7b 1795 return 0;
4ed46869
KH
1796}
1797
5232fa7b 1798#ifdef emacs
6ae21908 1799
5232fa7b 1800DEFUN ("ccl-program-p", Fccl_program_p, Sccl_program_p, 1, 1, 0,
fdb82f93
PJ
1801 doc: /* Return t if OBJECT is a CCL program name or a compiled CCL program code.
1802See the documentation of `define-ccl-program' for the detail of CCL program. */)
1803 (object)
5232fa7b 1804 Lisp_Object object;
6ae21908 1805{
5232fa7b 1806 Lisp_Object val;
6ae21908 1807
5232fa7b 1808 if (VECTORP (object))
6ae21908 1809 {
5232fa7b
KH
1810 val = resolve_symbol_ccl_program (object);
1811 return (VECTORP (val) ? Qt : Qnil);
6ae21908 1812 }
5232fa7b
KH
1813 if (!SYMBOLP (object))
1814 return Qnil;
6ae21908 1815
5232fa7b
KH
1816 val = Fget (object, Qccl_program_idx);
1817 return ((! NATNUMP (val)
64ef2921 1818 || XINT (val) >= ASIZE (Vccl_program_table))
5232fa7b 1819 ? Qnil : Qt);
6ae21908
KH
1820}
1821
4ed46869 1822DEFUN ("ccl-execute", Fccl_execute, Sccl_execute, 2, 2, 0,
fdb82f93
PJ
1823 doc: /* Execute CCL-PROGRAM with registers initialized by REGISTERS.
1824
1825CCL-PROGRAM is a CCL program name (symbol)
1826or compiled code generated by `ccl-compile' (for backward compatibility.
1827In the latter case, the execution overhead is bigger than in the former).
1828No I/O commands should appear in CCL-PROGRAM.
1829
1830REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value
1831for the Nth register.
1832
1833As side effect, each element of REGISTERS holds the value of
1834the corresponding register after the execution.
1835
1836See the documentation of `define-ccl-program' for a definition of CCL
1837programs. */)
1838 (ccl_prog, reg)
4ed46869
KH
1839 Lisp_Object ccl_prog, reg;
1840{
1841 struct ccl_program ccl;
1842 int i;
1843
5232fa7b
KH
1844 if (setup_ccl_program (&ccl, ccl_prog) < 0)
1845 error ("Invalid CCL program");
6ae21908 1846
b7826503 1847 CHECK_VECTOR (reg);
64ef2921 1848 if (ASIZE (reg) != 8)
d7e1fe1f 1849 error ("Length of vector REGISTERS is not 8");
4ed46869 1850
4ed46869 1851 for (i = 0; i < 8; i++)
64ef2921
SM
1852 ccl.reg[i] = (INTEGERP (AREF (reg, i))
1853 ? XINT (AREF (reg, i))
4ed46869
KH
1854 : 0);
1855
c10842ea 1856 ccl_driver (&ccl, NULL, NULL, 0, 0);
4ed46869
KH
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++)
64ef2921 1862 XSETINT (AREF (reg, i), ccl.reg[i]);
4ed46869
KH
1863 return Qnil;
1864}
1865
1866DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, Sccl_execute_on_string,
39a68837 1867 3, 5, 0,
fdb82f93
PJ
1868 doc: /* Execute CCL-PROGRAM with initial STATUS on STRING.
1869
1870CCL-PROGRAM is a symbol registered by register-ccl-program,
1871or a compiled code generated by `ccl-compile' (for backward compatibility,
1872in this case, the execution is slower).
1873
1874Read buffer is set to STRING, and write buffer is allocated automatically.
1875
1876STATUS 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.
1879If R0..R7 are nil, they are initialized to 0.
1880If IC is nil, it is initialized to head of the CCL program.
1881
1882If optional 4th arg CONTINUE is non-nil, keep IC on read operation
1883when read buffer is exausted, else, IC is always set to the end of
1884CCL-PROGRAM on exit.
1885
1886It returns the contents of write buffer as a string,
1887 and as side effect, STATUS is updated.
1888If the optional 5th arg UNIBYTE-P is non-nil, the returned string
1889is a unibyte string. By default it is a multibyte string.
1890
1891See the documentation of `define-ccl-program' for the detail of CCL program. */)
1892 (ccl_prog, status, str, contin, unibyte_p)
39a68837 1893 Lisp_Object ccl_prog, status, str, contin, unibyte_p;
4ed46869
KH
1894{
1895 Lisp_Object val;
1896 struct ccl_program ccl;
c10842ea 1897 int i;
4ed46869 1898 int outbufsize;
c10842ea
KH
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;
6ae21908 1904
5232fa7b
KH
1905 if (setup_ccl_program (&ccl, ccl_prog) < 0)
1906 error ("Invalid CCL program");
4ed46869 1907
b7826503 1908 CHECK_VECTOR (status);
64ef2921 1909 if (ASIZE (status) != 9)
5232fa7b 1910 error ("Length of vector STATUS is not 9");
b7826503 1911 CHECK_STRING (str);
c10842ea
KH
1912 str_chars = XSTRING (str)->size;
1913 str_bytes = STRING_BYTES (XSTRING (str));
5232fa7b 1914
4ed46869
KH
1915 for (i = 0; i < 8; i++)
1916 {
64ef2921
SM
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));
4ed46869 1921 }
64ef2921 1922 if (INTEGERP (AREF (status, i)))
4ed46869 1923 {
64ef2921 1924 i = XFASTINT (AREF (status, 8));
4ed46869
KH
1925 if (ccl.ic < i && i < ccl.size)
1926 ccl.ic = i;
1927 }
4ed46869 1928
c10842ea
KH
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)
a3d8fcf2 1937 {
c10842ea
KH
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 }
a3d8fcf2 1994
4ed46869 1995 if (ccl.status != CCL_STAT_SUCCESS
a3d8fcf2 1996 && ccl.status != CCL_STAT_SUSPEND_BY_SRC)
4ed46869 1997 error ("Error in CCL program at %dth code", ccl.ic);
c10842ea
KH
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);
4ed46869
KH
2009
2010 return val;
2011}
2012
2013DEFUN ("register-ccl-program", Fregister_ccl_program, Sregister_ccl_program,
2014 2, 2, 0,
fdb82f93
PJ
2015 doc: /* Register CCL program CCL_PROG as NAME in `ccl-program-table'.
2016CCL_PROG should be a compiled CCL program (vector), or nil.
2017If it is nil, just reserve NAME as a CCL program name.
2018Return index number of the registered CCL program. */)
2019 (name, ccl_prog)
4ed46869
KH
2020 Lisp_Object name, ccl_prog;
2021{
64ef2921 2022 int len = ASIZE (Vccl_program_table);
5232fa7b
KH
2023 int idx;
2024 Lisp_Object resolved;
4ed46869 2025
b7826503 2026 CHECK_SYMBOL (name);
5232fa7b 2027 resolved = Qnil;
4ed46869 2028 if (!NILP (ccl_prog))
6ae21908 2029 {
b7826503 2030 CHECK_VECTOR (ccl_prog);
5232fa7b 2031 resolved = resolve_symbol_ccl_program (ccl_prog);
4d247a1f
KH
2032 if (NILP (resolved))
2033 error ("Error in CCL program");
2034 if (VECTORP (resolved))
5232fa7b
KH
2035 {
2036 ccl_prog = resolved;
2037 resolved = Qt;
2038 }
4d247a1f
KH
2039 else
2040 resolved = Qnil;
6ae21908 2041 }
5232fa7b
KH
2042
2043 for (idx = 0; idx < len; idx++)
4ed46869 2044 {
5232fa7b 2045 Lisp_Object slot;
4ed46869 2046
64ef2921 2047 slot = AREF (Vccl_program_table, idx);
5232fa7b
KH
2048 if (!VECTORP (slot))
2049 /* This is the first unsed slot. Register NAME here. */
4ed46869
KH
2050 break;
2051
64ef2921 2052 if (EQ (name, AREF (slot, 0)))
4ed46869 2053 {
5232fa7b 2054 /* Update this slot. */
64ef2921
SM
2055 AREF (slot, 1) = ccl_prog;
2056 AREF (slot, 2) = resolved;
5232fa7b 2057 return make_number (idx);
4ed46869
KH
2058 }
2059 }
2060
5232fa7b 2061 if (idx == len)
4ed46869 2062 {
5232fa7b
KH
2063 /* Extend the table. */
2064 Lisp_Object new_table;
4ed46869
KH
2065 int j;
2066
5232fa7b 2067 new_table = Fmake_vector (make_number (len * 2), Qnil);
4ed46869 2068 for (j = 0; j < len; j++)
64ef2921
SM
2069 AREF (new_table, j)
2070 = AREF (Vccl_program_table, j);
4ed46869
KH
2071 Vccl_program_table = new_table;
2072 }
2073
5232fa7b
KH
2074 {
2075 Lisp_Object elt;
2076
2077 elt = Fmake_vector (make_number (3), Qnil);
64ef2921
SM
2078 AREF (elt, 0) = name;
2079 AREF (elt, 1) = ccl_prog;
2080 AREF (elt, 2) = resolved;
2081 AREF (Vccl_program_table, idx) = elt;
5232fa7b
KH
2082 }
2083
2084 Fput (name, Qccl_program_idx, make_number (idx));
2085 return make_number (idx);
4ed46869
KH
2086}
2087
8146262a
KH
2088/* Register code conversion map.
2089 A code conversion map consists of numbers, Qt, Qnil, and Qlambda.
d617f6df
DL
2090 The first element is the start code point.
2091 The other elements are mapped numbers.
8146262a
KH
2092 Symbol t means to map to an original number before mapping.
2093 Symbol nil means that the corresponding element is empty.
d617f6df 2094 Symbol lambda means to terminate mapping here.
e34b1164
KH
2095*/
2096
8146262a
KH
2097DEFUN ("register-code-conversion-map", Fregister_code_conversion_map,
2098 Sregister_code_conversion_map,
e34b1164 2099 2, 2, 0,
fdb82f93
PJ
2100 doc: /* Register SYMBOL as code conversion map MAP.
2101Return index number of the registered map. */)
2102 (symbol, map)
8146262a 2103 Lisp_Object symbol, map;
e34b1164 2104{
64ef2921 2105 int len = ASIZE (Vcode_conversion_map_vector);
e34b1164
KH
2106 int i;
2107 Lisp_Object index;
2108
b7826503
PJ
2109 CHECK_SYMBOL (symbol);
2110 CHECK_VECTOR (map);
e34b1164
KH
2111
2112 for (i = 0; i < len; i++)
2113 {
64ef2921 2114 Lisp_Object slot = AREF (Vcode_conversion_map_vector, i);
e34b1164
KH
2115
2116 if (!CONSP (slot))
2117 break;
2118
03699b14 2119 if (EQ (symbol, XCAR (slot)))
e34b1164
KH
2120 {
2121 index = make_number (i);
f3fbd155 2122 XSETCDR (slot, map);
8146262a
KH
2123 Fput (symbol, Qcode_conversion_map, map);
2124 Fput (symbol, Qcode_conversion_map_id, index);
e34b1164
KH
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++)
64ef2921
SM
2135 AREF (new_vector, j)
2136 = AREF (Vcode_conversion_map_vector, j);
8146262a 2137 Vcode_conversion_map_vector = new_vector;
e34b1164
KH
2138 }
2139
2140 index = make_number (i);
8146262a
KH
2141 Fput (symbol, Qcode_conversion_map, map);
2142 Fput (symbol, Qcode_conversion_map_id, index);
64ef2921 2143 AREF (Vcode_conversion_map_vector, i) = Fcons (symbol, map);
e34b1164
KH
2144 return index;
2145}
2146
2147
dfcf069d 2148void
4ed46869
KH
2149syms_of_ccl ()
2150{
2151 staticpro (&Vccl_program_table);
6703ac4f 2152 Vccl_program_table = Fmake_vector (make_number (32), Qnil);
4ed46869 2153
c10842ea
KH
2154 Qccl = intern ("ccl");
2155 staticpro (&Qccl);
2156
2157 Qcclp = intern ("cclp");
2158 staticpro (&Qcclp);
2159
6ae21908
KH
2160 Qccl_program = intern ("ccl-program");
2161 staticpro (&Qccl_program);
2162
2163 Qccl_program_idx = intern ("ccl-program-idx");
2164 staticpro (&Qccl_program_idx);
e34b1164 2165
8146262a
KH
2166 Qcode_conversion_map = intern ("code-conversion-map");
2167 staticpro (&Qcode_conversion_map);
6ae21908 2168
8146262a
KH
2169 Qcode_conversion_map_id = intern ("code-conversion-map-id");
2170 staticpro (&Qcode_conversion_map_id);
6ae21908 2171
8146262a 2172 DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector,
fdb82f93 2173 doc: /* Vector of code conversion maps. */);
8146262a 2174 Vcode_conversion_map_vector = Fmake_vector (make_number (16), Qnil);
e34b1164 2175
4ed46869 2176 DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist,
fdb82f93
PJ
2177 doc: /* Alist of fontname patterns vs corresponding CCL program.
2178Each element looks like (REGEXP . CCL-CODE),
2179 where CCL-CODE is a compiled CCL program.
2180When 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.
2184The 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. */);
4ed46869
KH
2187 Vfont_ccl_encoder_alist = Qnil;
2188
5232fa7b 2189 defsubr (&Sccl_program_p);
4ed46869
KH
2190 defsubr (&Sccl_execute);
2191 defsubr (&Sccl_execute_on_string);
2192 defsubr (&Sregister_ccl_program);
8146262a 2193 defsubr (&Sregister_code_conversion_map);
4ed46869
KH
2194}
2195
2196#endif /* emacs */