/* CCL (Code Conversion Language) interpreter.
- Ver.1.0
- Copyright (C) 1995 Free Software Foundation, Inc.
- Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+ Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
+ Licensed to the Free Software Foundation.
This file is part of GNU Emacs.
#ifdef emacs
#include <config.h>
+
+#ifdef STDC_HEADERS
+#include <stdlib.h>
+#endif
+
#include "lisp.h"
#include "charset.h"
#include "ccl.h"
#endif /* not emacs */
+/* Where is stored translation tables for CCL program. */
+Lisp_Object Vccl_translation_table_vector;
+
/* Alist of fontname patterns vs corresponding CCL program. */
Lisp_Object Vfont_ccl_encoder_alist;
+/* This symbol is a property which assocates with ccl program vector.
+ Ex: (get 'ccl-big5-encoder 'ccl-program) returns ccl program vector. */
+Lisp_Object Qccl_program;
+
+/* These symbols are properties which associate with ccl translation
+ tables and their ID respectively. */
+Lisp_Object Qccl_translation_table;
+Lisp_Object Qccl_translation_table_id;
+
+/* Symbols of ccl program have this property, a value of the property
+ is an index for Vccl_protram_table. */
+Lisp_Object Qccl_program_idx;
+
+/* These symbols are properties which associate with character
+ unification tables and their ID respectively. */
+Lisp_Object Qunification_table;
+Lisp_Object Qunification_table_id;
+
/* Vector of CCL program names vs corresponding program data. */
Lisp_Object Vccl_program_table;
IC += ADDRESS;
*/
/* Note: If read is suspended, the resumed execution starts from the
- Mth code (YYYYY == CCL_ReadJump). */
+ Nth code (YYYYY == CCL_ReadJump). */
#define CCL_ReadJump 0x0C /* Read and jump:
1:A--D--D--R--E--S--S-rrrYYYYY
write (reg[RRR] OPERATION reg[Rrr]);
*/
-#define CCL_Call 0x13 /* Write a constant:
+#define CCL_Call 0x13 /* Call the CCL program whose ID is
+ (CC..C).
1:CCCCCCCCCCCCCCCCCCCC000XXXXX
------------------------------
call (CC..C)
extended_command (rrr,RRR,Rrr,ARGS)
*/
+/*
+ Here after, Extended CCL Instructions.
+ Bit length of extended command is 14.
+ Therefore, the instruction code range is 0..16384(0x3fff).
+ */
+
+/* Read a multibyte characeter.
+ A code point is stored into reg[rrr]. A charset ID is stored into
+ reg[RRR]. */
+
+#define CCL_ReadMultibyteChar2 0x00 /* Read Multibyte Character
+ 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
+
+/* Write a multibyte character.
+ Write a character whose code point is reg[rrr] and the charset ID
+ is reg[RRR]. */
+
+#define CCL_WriteMultibyteChar2 0x01 /* Write Multibyte Character
+ 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
+
+/* Unify a character whose code point is reg[rrr] the charset ID is
+ reg[RRR] with a unification table whose ID is reg[Rrr].
+
+ A unified character is set in reg[rrr] (code point) and reg[RRR]
+ (charset ID). */
+
+#define CCL_UnifyCharacter 0x02 /* Unify Multibyte Character
+ 1:ExtendedCOMMNDRrrRRRrrrXXXXX */
+
+/* Unify a character whose code point is reg[rrr] and the charset ID
+ is reg[RRR] with a unification table whose ID is ARGUMENT.
+
+ A unified character is set in reg[rrr] (code point) and reg[RRR]
+ (charset ID). */
+
+#define CCL_UnifyCharacterConstTbl 0x03 /* Unify Multibyte Character
+ 1:ExtendedCOMMNDRrrRRRrrrXXXXX
+ 2:ARGUMENT(Unification Table ID)
+ */
+
+/* Iterate looking up TABLEs for reg[rrr] starting from the Nth (N =
+ reg[RRR]) TABLE until some value is found.
+
+ Each TABLE is a Lisp vector whose element is number, nil, t, or
+ lambda.
+ If the element is nil, ignore the table and proceed to the next table.
+ If the element is t or lambda, finish without changing reg[rrr].
+ If the element is a number, set reg[rrr] to the number and finish.
+
+ Detail of the table structure is descibed in the comment for
+ CCL_TranslateMultipleMap below. */
+
+#define CCL_IterateMultipleMap 0x10 /* Iterate Multiple Map
+ 1:ExtendedCOMMNDXXXRRRrrrXXXXX
+ 2:NUMBER of TABLEs
+ 3:TABLE-ID1
+ 4:TABLE-ID2
+ ...
+ */
+
+/* Translate code point reg[rrr] by TABLEs starting from the Nth (N =
+ reg[RRR]) table.
+
+ TABLEs are suppried in the succeeding CCL codes as follows:
+
+ When CCL program gives this nested structure of table to this command:
+ ((TABLE-ID11
+ TABLE-ID12
+ (TABLE-ID121 TABLE-ID122 TABLE-ID123)
+ TABLE-ID13)
+ (TABLE-ID21
+ (TABLE-ID211 (TABLE-ID2111) TABLE-ID212)
+ TABLE-ID22)),
+ the compiled CCL codes has this sequence:
+ CCL_TranslateMultipleMap (CCL code of this command)
+ 16 (total number of TABLEs and SEPARATERs)
+ -7 (1st SEPARATER)
+ TABLE-ID11
+ TABLE-ID12
+ -3 (2nd SEPARATER)
+ TABLE-ID121
+ TABLE-ID122
+ TABLE-ID123
+ TABLE-ID13
+ -7 (3rd SEPARATER)
+ TABLE-ID21
+ -4 (4th SEPARATER)
+ TABLE-ID211
+ -1 (5th SEPARATER)
+ TABLE_ID2111
+ TABLE-ID212
+ TABLE-ID22
+
+ A value of each SEPARATER follows this rule:
+ TABLE-SET := SEPARATOR [(TABLE-ID | TABLE-SET)]+
+ SEPARATOR := -(number of TABLE-IDs and SEPARATORs in the TABLE-SET)
+
+ (*)....Nest level of TABLE-SET must not be over than MAX_TABLE_SET_LEVEL.
+
+ When some table fails to translate (i.e. it doesn't have a value
+ for reg[rrr]), the translation is treated as identity.
+
+ The translation is iterated for all tables in each table set (set
+ of tables separators by a SEPARATOR) except the case that lambda is
+ encountered (see below).
+
+ Each table is a Lisp vector of the following format (a) or (b):
+ (a)......[STARTPOINT VAL1 VAL2 ...]
+ (b)......[t VAL STARTPOINT ENDPOINT],
+ where
+ STARTPOINT is an offset to be used for indexing a table,
+ ENDPOINT is a maxmum index number of a table,
+ VAL and VALn is a number, nil, t, or lambda.
+
+ Valid index range of a table of type (a) is:
+ STARTPOINT <= index < STARTPOINT + table_size - 1
+ Valid index range of a table of type (b) is:
+ STARTPOINT <= index < ENDPOINT
+
+ If VALn is nil, the table is ignored and translation proceed to the
+ next table.
+ In VALn is t, reg[rrr] is reverted to the original value and
+ translation proceed to the next table.
+ If VALn is lambda, translation in the current TABLE-SET finishes
+ and proceed to the upper level TABLE-SET. */
+
+#define CCL_TranslateMultipleMap 0x11 /* Translate Multiple Map
+ 1:ExtendedCOMMNDXXXRRRrrrXXXXX
+ 2:N-2
+ 3:SEPARATOR_1 (< 0)
+ 4:TABLE-ID_1
+ 5:TABLE-ID_2
+ ...
+ M:SEPARATOR_x (< 0)
+ M+1:TABLE-ID_y
+ ...
+ N:SEPARATOR_z (< 0)
+ */
+
+#define MAX_TABLE_SET_LEVEL 20
+
+typedef struct
+{
+ int rest_length;
+ int orig_val;
+} tr_stack;
+
+static tr_stack translate_stack[MAX_TABLE_SET_LEVEL];
+static tr_stack *translate_stack_pointer;
+
+#define PUSH_TRANSLATE_STACK(restlen, orig) \
+{ \
+ translate_stack_pointer->rest_length = (restlen); \
+ translate_stack_pointer->orig_val = (orig); \
+ translate_stack_pointer++; \
+}
+
+#define POP_TRANSLATE_STACK(restlen, orig) \
+{ \
+ translate_stack_pointer--; \
+ (restlen) = translate_stack_pointer->rest_length; \
+ (orig) = translate_stack_pointer->orig_val; \
+} \
+
+#define CCL_TranslateSingleMap 0x12 /* Translate Single Map
+ 1:ExtendedCOMMNDXXXRRRrrrXXXXX
+ 2:TABLE-ID
+ ------------------------------
+ Translate reg[rrr] by TABLE-ID.
+ If some valid translation is found,
+ set reg[rrr] to the result,
+ else
+ set reg[RRR] to -1.
+ */
/* CCL arithmetic/logical operators. */
#define CCL_PLUS 0x00 /* X = Y + Z */
#define CCL_DECODE_SJIS 0x17 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
-/* Macros for exit status of CCL program. */
-#define CCL_STAT_SUCCESS 0 /* Terminated successfully. */
-#define CCL_STAT_SUSPEND 1 /* Terminated because of empty input
- buffer or full output buffer. */
-#define CCL_STAT_INVALID_CMD 2 /* Terminated because of invalid
- command. */
-#define CCL_STAT_QUIT 3 /* Terminated because of quit. */
-
/* Terminate CCL program successfully. */
#define CCL_SUCCESS \
do { \
/* Suspend CCL program because of reading from empty input buffer or
writing to full output buffer. When this program is resumed, the
same I/O command is executed. */
-#define CCL_SUSPEND \
- do { \
- ic--; \
- ccl->status = CCL_STAT_SUSPEND; \
- goto ccl_finish; \
+#define CCL_SUSPEND(stat) \
+ do { \
+ ic--; \
+ ccl->status = stat; \
+ goto ccl_finish; \
} while (0)
/* Terminate CCL program because of invalid command. Should not occur
} while (0)
/* Encode one character CH to multibyte form and write to the current
- output buffer. If CH is negative, write one byte -CH. */
-#define CCL_WRITE_CHAR(ch) \
- do { \
- if (!dst) \
- CCL_INVALID_CMD; \
- else \
- { \
- unsigned char work[4], *str; \
- int len = CHAR_STRING (ch, work, str); \
- if (dst + len <= dst_end) \
- { \
- bcopy (str, dst, len); \
- dst += len; \
- } \
- else \
- CCL_SUSPEND; \
- } \
+ output buffer. If CH is less than 256, CH is written as is. */
+#define CCL_WRITE_CHAR(ch) \
+ do { \
+ if (!dst) \
+ CCL_INVALID_CMD; \
+ else \
+ { \
+ unsigned char work[4], *str; \
+ int len = CHAR_STRING (ch, work, str); \
+ if (dst + len <= (dst_bytes ? dst_end : src)) \
+ { \
+ bcopy (str, dst, len); \
+ dst += len; \
+ } \
+ else \
+ CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
+ } \
} while (0)
/* Write a string at ccl_prog[IC] of length LEN to the current output
do { \
if (!dst) \
CCL_INVALID_CMD; \
- else if (dst + len <= dst_end) \
+ else if (dst + len <= (dst_bytes ? dst_end : src)) \
for (i = 0; i < len; i++) \
*dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
>> ((2 - (i % 3)) * 8)) & 0xFF; \
else \
- CCL_SUSPEND; \
+ CCL_SUSPEND (CCL_STAT_SUSPEND_BY_DST); \
} while (0)
/* Read one byte from the current input buffer into Rth register. */
-#define CCL_READ_CHAR(r) \
- do { \
- if (!src) \
- CCL_INVALID_CMD; \
- else if (src < src_end) \
- r = *src++; \
- else if (ccl->last_block) \
- { \
- ic = ccl->eof_ic; \
- goto ccl_finish; \
- } \
- else \
- CCL_SUSPEND; \
+#define CCL_READ_CHAR(r) \
+ do { \
+ if (!src) \
+ CCL_INVALID_CMD; \
+ else if (src < src_end) \
+ r = *src++; \
+ else if (ccl->last_block) \
+ { \
+ ic = ccl->eof_ic; \
+ goto ccl_finish; \
+ } \
+ else \
+ CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \
} while (0)
struct ccl_prog_stack
{
- int *ccl_prog; /* Pointer to an array of CCL code. */
+ Lisp_Object *ccl_prog; /* Pointer to an array of CCL code. */
int ic; /* Instruction Counter. */
};
+int
ccl_driver (ccl, source, destination, src_bytes, dst_bytes, consumed)
struct ccl_program *ccl;
unsigned char *source, *destination;
register int *reg = ccl->reg;
register int ic = ccl->ic;
register int code, field1, field2;
- register int *ccl_prog = ccl->prog;
+ register Lisp_Object *ccl_prog = ccl->prog;
unsigned char *src = source, *src_end = src + src_bytes;
unsigned char *dst = destination, *dst_end = dst + dst_bytes;
int jump_address;
#define RRR (field1 & 7)
#define Rrr ((field1 >> 3) & 7)
#define ADDR field1
+#define EXCMD (field1 >> 6)
switch (code & 0x1F)
{
case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
i = reg[rrr];
- j = ccl_prog[ic++];
+ j = XINT (ccl_prog[ic]);
if ((unsigned int) i < j)
{
- i = XINT (ccl_prog[ic + i]);
+ i = XINT (ccl_prog[ic + 1 + i]);
CCL_WRITE_CHAR (i);
}
- ic += j + 1;
+ ic += j + 2;
CCL_READ_CHAR (reg[rrr]);
ic += ADDR - (j + 2);
break;
ic = jump_address;
break;
+ case CCL_Extention:
+ switch (EXCMD)
+ {
+ case CCL_ReadMultibyteChar2:
+ if (!src)
+ CCL_INVALID_CMD;
+ do {
+ if (src >= src_end)
+ {
+ src++;
+ goto ccl_read_multibyte_character_suspend;
+ }
+
+ i = *src++;
+ if (i == LEADING_CODE_COMPOSITION)
+ {
+ if (src >= src_end)
+ goto ccl_read_multibyte_character_suspend;
+ if (*src == 0xFF)
+ {
+ ccl->private_state = COMPOSING_WITH_RULE_HEAD;
+ src++;
+ }
+ else
+ ccl->private_state = COMPOSING_NO_RULE_HEAD;
+ }
+ if (ccl->private_state != 0)
+ {
+ /* composite character */
+ if (*src < 0xA0)
+ ccl->private_state = 0;
+ else
+ {
+ if (i == 0xA0)
+ {
+ if (src >= src_end)
+ goto ccl_read_multibyte_character_suspend;
+ i = *src++ & 0x7F;
+ }
+ else
+ i -= 0x20;
+
+ if (COMPOSING_WITH_RULE_RULE == ccl->private_state)
+ {
+ ccl->private_state = COMPOSING_WITH_RULE_HEAD;
+ continue;
+ }
+ else if (COMPOSING_WITH_RULE_HEAD == ccl->private_state)
+ ccl->private_state = COMPOSING_WITH_RULE_RULE;
+ }
+ }
+ if (i < 0x80)
+ {
+ /* ASCII */
+ reg[rrr] = i;
+ reg[RRR] = CHARSET_ASCII;
+ }
+ else if (i <= MAX_CHARSET_OFFICIAL_DIMENSION1)
+ {
+ if (src >= src_end)
+ goto ccl_read_multibyte_character_suspend;
+ reg[RRR] = i;
+ reg[rrr] = (*src++ & 0x7F);
+ }
+ else if (i <= MAX_CHARSET_OFFICIAL_DIMENSION2)
+ {
+ if ((src + 1) >= src_end)
+ goto ccl_read_multibyte_character_suspend;
+ reg[RRR] = i;
+ i = (*src++ & 0x7F);
+ reg[rrr] = ((i << 7) | (*src & 0x7F));
+ src++;
+ }
+ else if ((i == LEADING_CODE_PRIVATE_11)
+ || (i == LEADING_CODE_PRIVATE_12))
+ {
+ if ((src + 1) >= src_end)
+ goto ccl_read_multibyte_character_suspend;
+ reg[RRR] = *src++;
+ reg[rrr] = (*src++ & 0x7F);
+ }
+ else if ((i == LEADING_CODE_PRIVATE_21)
+ || (i == LEADING_CODE_PRIVATE_22))
+ {
+ if ((src + 2) >= src_end)
+ goto ccl_read_multibyte_character_suspend;
+ reg[RRR] = *src++;
+ i = (*src++ & 0x7F);
+ reg[rrr] = ((i << 7) | (*src & 0x7F));
+ src++;
+ }
+ else
+ {
+ /* INVALID CODE
+ Returned charset is -1. */
+ reg[RRR] = -1;
+ }
+ } while (0);
+ break;
+
+ ccl_read_multibyte_character_suspend:
+ src--;
+ if (ccl->last_block)
+ {
+ ic = ccl->eof_ic;
+ goto ccl_finish;
+ }
+ else
+ CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC);
+
+ break;
+
+ case CCL_WriteMultibyteChar2:
+ i = reg[RRR]; /* charset */
+ if (i == CHARSET_ASCII)
+ i = reg[rrr] & 0x7F;
+ else if (i == CHARSET_COMPOSITION)
+ i = MAKE_COMPOSITE_CHAR (reg[rrr]);
+ else if (CHARSET_DIMENSION (i) == 1)
+ i = ((i - 0x70) << 7) | (reg[rrr] & 0x7F);
+ else if (i < MIN_CHARSET_PRIVATE_DIMENSION2)
+ i = ((i - 0x8F) << 14) | reg[rrr];
+ else
+ i = ((i - 0xE0) << 14) | reg[rrr];
+
+ CCL_WRITE_CHAR (i);
+
+ break;
+
+ case CCL_UnifyCharacter:
+ i = reg[RRR]; /* charset */
+ if (i == CHARSET_ASCII)
+ i = reg[rrr] & 0x7F;
+ else if (i == CHARSET_COMPOSITION)
+ {
+ reg[RRR] = -1;
+ break;
+ }
+ else if (CHARSET_DIMENSION (i) == 1)
+ i = ((i - 0x70) << 7) | (reg[rrr] & 0x7F);
+ else if (i < MIN_CHARSET_PRIVATE_DIMENSION2)
+ i = ((i - 0x8F) << 14) | (reg[rrr] & 0x3FFF);
+ else
+ i = ((i - 0xE0) << 14) | (reg[rrr] & 0x3FFF);
+
+ op = unify_char (UNIFICATION_ID_TABLE (reg[Rrr]), i, -1, 0, 0);
+ SPLIT_CHAR (op, reg[RRR], i, j);
+ if (j != -1)
+ i = (i << 7) | j;
+
+ reg[rrr] = i;
+ break;
+
+ case CCL_UnifyCharacterConstTbl:
+ op = XINT (ccl_prog[ic]); /* table */
+ ic++;
+ i = reg[RRR]; /* charset */
+ if (i == CHARSET_ASCII)
+ i = reg[rrr] & 0x7F;
+ else if (i == CHARSET_COMPOSITION)
+ {
+ reg[RRR] = -1;
+ break;
+ }
+ else if (CHARSET_DIMENSION (i) == 1)
+ i = ((i - 0x70) << 7) | (reg[rrr] & 0x7F);
+ else if (i < MIN_CHARSET_PRIVATE_DIMENSION2)
+ i = ((i - 0x8F) << 14) | (reg[rrr] & 0x3FFF);
+ else
+ i = ((i - 0xE0) << 14) | (reg[rrr] & 0x3FFF);
+
+ op = unify_char (UNIFICATION_ID_TABLE (op), i, -1, 0, 0);
+ SPLIT_CHAR (op, reg[RRR], i, j);
+ if (j != -1)
+ i = (i << 7) | j;
+
+ reg[rrr] = i;
+ break;
+
+ case CCL_IterateMultipleMap:
+ {
+ Lisp_Object table, content, attrib, value;
+ int point, size, fin_ic;
+
+ j = XINT (ccl_prog[ic++]); /* number of tables. */
+ fin_ic = ic + j;
+ op = reg[rrr];
+ if ((j > reg[RRR]) && (j >= 0))
+ {
+ ic += reg[RRR];
+ i = reg[RRR];
+ }
+ else
+ {
+ reg[RRR] = -1;
+ ic = fin_ic;
+ break;
+ }
+
+ for (;i < j;i++)
+ {
+
+ size = XVECTOR (Vccl_translation_table_vector)->size;
+ point = XINT (ccl_prog[ic++]);
+ if (point >= size) continue;
+ table =
+ XVECTOR (Vccl_translation_table_vector)->contents[point];
+
+ /* Check table varidity. */
+ if (!CONSP (table)) continue;
+ table = XCONS(table)->cdr;
+ if (!VECTORP (table)) continue;
+ size = XVECTOR (table)->size;
+ if (size <= 1) continue;
+
+ content = XVECTOR (table)->contents[0];
+
+ /* check table type,
+ [STARTPOINT VAL1 VAL2 ...] or
+ [t ELELMENT STARTPOINT ENDPOINT] */
+ if (NUMBERP (content))
+ {
+ point = XUINT (content);
+ point = op - point + 1;
+ if (!((point >= 1) && (point < size))) continue;
+ content = XVECTOR (table)->contents[point];
+ }
+ else if (EQ (content, Qt))
+ {
+ if (size != 4) continue;
+ if ((op >= XUINT (XVECTOR (table)->contents[2]))
+ && (op < XUINT (XVECTOR (table)->contents[3])))
+ content = XVECTOR (table)->contents[1];
+ else
+ continue;
+ }
+ else
+ continue;
+
+ if (NILP (content))
+ continue;
+ else if (NUMBERP (content))
+ {
+ reg[RRR] = i;
+ reg[rrr] = XINT(content);
+ break;
+ }
+ else if (EQ (content, Qt) || EQ (content, Qlambda))
+ {
+ reg[RRR] = i;
+ break;
+ }
+ else if (CONSP (content))
+ {
+ attrib = XCONS (content)->car;
+ value = XCONS (content)->cdr;
+ if (!NUMBERP (attrib) || !NUMBERP (value))
+ continue;
+ reg[RRR] = i;
+ reg[rrr] = XUINT (value);
+ break;
+ }
+ }
+ if (i == j)
+ reg[RRR] = -1;
+ ic = fin_ic;
+ }
+ break;
+
+ case CCL_TranslateMultipleMap:
+ {
+ Lisp_Object table, content, attrib, value;
+ int point, size, table_vector_size;
+ int table_set_rest_length, fin_ic;
+
+ table_set_rest_length =
+ XINT (ccl_prog[ic++]); /* number of tables and separators. */
+ fin_ic = ic + table_set_rest_length;
+ if ((table_set_rest_length > reg[RRR]) && (reg[RRR] >= 0))
+ {
+ ic += reg[RRR];
+ i = reg[RRR];
+ table_set_rest_length -= i;
+ }
+ else
+ {
+ ic = fin_ic;
+ reg[RRR] = -1;
+ break;
+ }
+ translate_stack_pointer = translate_stack;
+ op = reg[rrr];
+ PUSH_TRANSLATE_STACK (0, op);
+ reg[RRR] = -1;
+ table_vector_size
+ = XVECTOR (Vccl_translation_table_vector)->size;
+ for (;table_set_rest_length > 0;i++, table_set_rest_length--)
+ {
+ point = XINT(ccl_prog[ic++]);
+ if (point < 0)
+ {
+ point = -point;
+ if (translate_stack_pointer
+ >= &translate_stack[MAX_TABLE_SET_LEVEL])
+ {
+ CCL_INVALID_CMD;
+ }
+ PUSH_TRANSLATE_STACK (table_set_rest_length - point,
+ reg[rrr]);
+ table_set_rest_length = point + 1;
+ reg[rrr] = op;
+ continue;
+ }
+
+ if (point >= table_vector_size) continue;
+ table =
+ XVECTOR (Vccl_translation_table_vector)->contents[point];
+
+ /* Check table varidity. */
+ if (!CONSP (table)) continue;
+ table = XCONS (table)->cdr;
+ if (!VECTORP (table)) continue;
+ size = XVECTOR (table)->size;
+ if (size <= 1) continue;
+
+ content = XVECTOR (table)->contents[0];
+
+ /* check table type,
+ [STARTPOINT VAL1 VAL2 ...] or
+ [t ELEMENT STARTPOINT ENDPOINT] */
+ if (NUMBERP (content))
+ {
+ point = XUINT (content);
+ point = op - point + 1;
+ if (!((point >= 1) && (point < size))) continue;
+ content = XVECTOR (table)->contents[point];
+ }
+ else if (EQ (content, Qt))
+ {
+ if (size != 4) continue;
+ if ((op >= XUINT (XVECTOR (table)->contents[2])) &&
+ (op < XUINT (XVECTOR (table)->contents[3])))
+ content = XVECTOR (table)->contents[1];
+ else
+ continue;
+ }
+ else
+ continue;
+
+ if (NILP (content))
+ continue;
+ else if (NUMBERP (content))
+ {
+ op = XINT (content);
+ reg[RRR] = i;
+ i += table_set_rest_length;
+ POP_TRANSLATE_STACK (table_set_rest_length, reg[rrr]);
+ }
+ else if (CONSP (content))
+ {
+ attrib = XCONS (content)->car;
+ value = XCONS (content)->cdr;
+ if (!NUMBERP (attrib) || !NUMBERP (value))
+ continue;
+ reg[RRR] = i;
+ op = XUINT (value);
+ i += table_set_rest_length;
+ POP_TRANSLATE_STACK (table_set_rest_length, reg[rrr]);
+ }
+ else if (EQ (content, Qt))
+ {
+ reg[RRR] = i;
+ op = reg[rrr];
+ i += table_set_rest_length;
+ POP_TRANSLATE_STACK (table_set_rest_length, reg[rrr]);
+ }
+ else if (EQ (content, Qlambda))
+ {
+ break;
+ }
+ else
+ CCL_INVALID_CMD;
+ }
+ ic = fin_ic;
+ }
+ reg[rrr] = op;
+ break;
+
+ case CCL_TranslateSingleMap:
+ {
+ Lisp_Object table, attrib, value, content;
+ int size, point;
+ j = XINT (ccl_prog[ic++]); /* table_id */
+ op = reg[rrr];
+ if (j >= XVECTOR (Vccl_translation_table_vector)->size)
+ {
+ reg[RRR] = -1;
+ break;
+ }
+ table = XVECTOR (Vccl_translation_table_vector)->contents[j];
+ if (!CONSP (table))
+ {
+ reg[RRR] = -1;
+ break;
+ }
+ table = XCONS(table)->cdr;
+ if (!VECTORP (table))
+ {
+ reg[RRR] = -1;
+ break;
+ }
+ size = XVECTOR (table)->size;
+ point = XUINT (XVECTOR (table)->contents[0]);
+ point = op - point + 1;
+ reg[RRR] = 0;
+ if ((size <= 1) ||
+ (!((point >= 1) && (point < size))))
+ reg[RRR] = -1;
+ else
+ {
+ content = XVECTOR (table)->contents[point];
+ if (NILP (content))
+ reg[RRR] = -1;
+ else if (NUMBERP (content))
+ reg[rrr] = XINT (content);
+ else if (EQ (content, Qt))
+ reg[RRR] = i;
+ else if (CONSP (content))
+ {
+ attrib = XCONS (content)->car;
+ value = XCONS (content)->cdr;
+ if (!NUMBERP (attrib) || !NUMBERP (value))
+ continue;
+ reg[rrr] = XUINT(value);
+ break;
+ }
+ else
+ reg[RRR] = -1;
+ }
+ }
+ break;
+
+ default:
+ CCL_INVALID_CMD;
+ }
+ break;
+
default:
CCL_INVALID_CMD;
}
dst += msglen;
}
}
- goto ccl_finish;
#endif
+ goto ccl_finish;
case CCL_STAT_QUIT:
sprintf(msg, "\nCCL: Quited.");
/* Setup fields of the structure pointed by CCL appropriately for the
execution of compiled CCL code in VEC (vector of integer). */
+void
setup_ccl_program (ccl, vec)
struct ccl_program *ccl;
Lisp_Object vec;
for (i = 0; i < 8; i++)
ccl->reg[i] = 0;
ccl->last_block = 0;
+ ccl->private_state = 0;
ccl->status = 0;
}
+/* Resolve symbols in the specified CCL code (Lisp vector). This
+ function converts translation-table and unification-table symbols
+ embeded in the CCL code into their ID numbers. */
+
+Lisp_Object
+resolve_symbol_ccl_program (ccl)
+ Lisp_Object ccl;
+{
+ int i, veclen;
+ Lisp_Object result, contents, prop;
+
+ result = ccl;
+ veclen = XVECTOR (result)->size;
+
+ /* Set CCL program's table ID */
+ for (i = 0; i < veclen; i++)
+ {
+ contents = XVECTOR (result)->contents[i];
+ if (SYMBOLP (contents))
+ {
+ if (EQ(result, ccl))
+ result = Fcopy_sequence (ccl);
+
+ prop = Fget (contents, Qunification_table_id);
+ if (NUMBERP (prop))
+ {
+ XVECTOR (result)->contents[i] = prop;
+ continue;
+ }
+ prop = Fget (contents, Qccl_translation_table_id);
+ if (NUMBERP (prop))
+ {
+ XVECTOR (result)->contents[i] = prop;
+ continue;
+ }
+ prop = Fget (contents, Qccl_program_idx);
+ if (NUMBERP (prop))
+ {
+ XVECTOR (result)->contents[i] = prop;
+ continue;
+ }
+ }
+ }
+
+ return result;
+}
+
+
#ifdef emacs
DEFUN ("ccl-execute", Fccl_execute, Sccl_execute, 2, 2, 0,
"Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
-CCL-PROGRAM is a compiled code generated by `ccl-compile',\n\
- no I/O commands should appear in the CCL program.\n\
+\n\
+CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
+or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
+in this case, the execution is slower).\n\
+No I/O commands should appear in CCL-PROGRAM.\n\
+\n\
REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
of Nth register.\n\
-As side effect, each element of REGISTER holds the value of\n\
+\n\
+As side effect, each element of REGISTERS holds the value of\n\
corresponding register after the execution.")
(ccl_prog, reg)
Lisp_Object ccl_prog, reg;
{
struct ccl_program ccl;
int i;
+ Lisp_Object ccl_id;
- CHECK_VECTOR (ccl_prog, 0);
- CHECK_VECTOR (reg, 1);
+ if ((SYMBOLP (ccl_prog)) &&
+ (!NILP (ccl_id = Fget (ccl_prog, Qccl_program_idx))))
+ {
+ ccl_prog = XVECTOR (Vccl_program_table)->contents[XUINT (ccl_id)];
+ CHECK_LIST (ccl_prog, 0);
+ ccl_prog = XCONS (ccl_prog)->cdr;
+ CHECK_VECTOR (ccl_prog, 1);
+ }
+ else
+ {
+ CHECK_VECTOR (ccl_prog, 1);
+ ccl_prog = resolve_symbol_ccl_program (ccl_prog);
+ }
+
+ CHECK_VECTOR (reg, 2);
if (XVECTOR (reg)->size != 8)
error ("Invalid length of vector REGISTERS");
}
DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, Sccl_execute_on_string,
- 3, 3, 0,
+ 3, 5, 0,
"Execute CCL-PROGRAM with initial STATUS on STRING.\n\
-CCL-PROGRAM is a compiled code generated by `ccl-compile'.\n\
+\n\
+CCL-PROGRAM is a symbol registered by register-ccl-program,\n\
+or a compiled code generated by `ccl-compile' (for backward compatibility,\n\
+in this case, the execution is slower).\n\
+\n\
Read buffer is set to STRING, and write buffer is allocated automatically.\n\
+\n\
STATUS is a vector of [R0 R1 ... R7 IC], where\n\
R0..R7 are initial values of corresponding registers,\n\
IC is the instruction counter specifying from where to start the program.\n\
If R0..R7 are nil, they are initialized to 0.\n\
If IC is nil, it is initialized to head of the CCL program.\n\
-Returns the contents of write buffer as a string,\n\
- and as side effect, STATUS is updated.")
- (ccl_prog, status, str)
- Lisp_Object ccl_prog, status, str;
+\n\
+If optional 4th arg CONTINUE is non-nil, keep IC on read operation\n\
+when read buffer is exausted, else, IC is always set to the end of\n\
+CCL-PROGRAM on exit.\n\
+\n\
+It returns the contents of write buffer as a string,\n\
+ and as side effect, STATUS is updated.\n\
+If the optional 5th arg UNIBYTE-P is non-nil, the returned string\n\
+is a unibyte string. By default it is a multibyte string.")
+ (ccl_prog, status, str, contin, unibyte_p)
+ Lisp_Object ccl_prog, status, str, contin, unibyte_p;
{
Lisp_Object val;
struct ccl_program ccl;
int outbufsize;
char *outbuf;
struct gcpro gcpro1, gcpro2, gcpro3;
+ Lisp_Object ccl_id;
+
+ if ((SYMBOLP (ccl_prog)) &&
+ (!NILP (ccl_id = Fget (ccl_prog, Qccl_program_idx))))
+ {
+ ccl_prog = XVECTOR (Vccl_program_table)->contents[XUINT (ccl_id)];
+ CHECK_LIST (ccl_prog, 0);
+ ccl_prog = XCONS (ccl_prog)->cdr;
+ CHECK_VECTOR (ccl_prog, 1);
+ }
+ else
+ {
+ CHECK_VECTOR (ccl_prog, 1);
+ ccl_prog = resolve_symbol_ccl_program (ccl_prog);
+ }
- CHECK_VECTOR (ccl_prog, 0);
CHECK_VECTOR (status, 1);
if (XVECTOR (status)->size != 9)
error ("Invalid length of vector STATUS");
if (ccl.ic < i && i < ccl.size)
ccl.ic = i;
}
- outbufsize = XSTRING (str)->size * ccl.buf_magnification + 256;
+ outbufsize = STRING_BYTES (XSTRING (str)) * ccl.buf_magnification + 256;
outbuf = (char *) xmalloc (outbufsize);
if (!outbuf)
error ("Not enough memory");
- ccl.last_block = 1;
+ ccl.last_block = NILP (contin);
produced = ccl_driver (&ccl, XSTRING (str)->data, outbuf,
- XSTRING (str)->size, outbufsize, (int *)0);
+ STRING_BYTES (XSTRING (str)), outbufsize, (int *)0);
for (i = 0; i < 8; i++)
XSET (XVECTOR (status)->contents[i], Lisp_Int, ccl.reg[i]);
XSETINT (XVECTOR (status)->contents[8], ccl.ic);
UNGCPRO;
- val = make_string (outbuf, produced);
+ if (NILP (unibyte_p))
+ val = make_string (outbuf, produced);
+ else
+ val = make_unibyte_string (outbuf, produced);
free (outbuf);
QUIT;
if (ccl.status != CCL_STAT_SUCCESS
- && ccl.status != CCL_STAT_SUSPEND)
+ && ccl.status != CCL_STAT_SUSPEND_BY_SRC
+ && ccl.status != CCL_STAT_SUSPEND_BY_DST)
error ("Error in CCL program at %dth code", ccl.ic);
return val;
DEFUN ("register-ccl-program", Fregister_ccl_program, Sregister_ccl_program,
2, 2, 0,
- "Register CCL program PROGRAM of NAME in `ccl-program-table'.
-PROGRAM should be a compiled code of CCL program, or nil.
+ "Register CCL program PROGRAM of NAME in `ccl-program-table'.\n\
+PROGRAM should be a compiled code of CCL program, or nil.\n\
Return index number of the registered CCL program.")
(name, ccl_prog)
Lisp_Object name, ccl_prog;
{
int len = XVECTOR (Vccl_program_table)->size;
- int i, idx;
+ int i;
CHECK_SYMBOL (name, 0);
if (!NILP (ccl_prog))
- CHECK_VECTOR (ccl_prog, 1);
+ {
+ CHECK_VECTOR (ccl_prog, 1);
+ ccl_prog = resolve_symbol_ccl_program (ccl_prog);
+ }
for (i = 0; i < len; i++)
{
if (i == len)
{
- Lisp_Object new_table = Fmake_vector (len * 2, Qnil);
+ Lisp_Object new_table = Fmake_vector (make_number (len * 2), Qnil);
int j;
for (j = 0; j < len; j++)
return make_number (i);
}
+/* register CCL translation table.
+ CCL translation table consists of numbers and Qt and Qnil and Qlambda.
+ The first element is start code point.
+ The rest elements are translated numbers.
+ Qt shows that an original number before translation.
+ Qnil shows that an empty element.
+ Qlambda makes translation stopped.
+*/
+
+DEFUN ("register-ccl-translation-table", Fregister_ccl_translation_table,
+ Sregister_ccl_translation_table,
+ 2, 2, 0,
+ "Register CCL translation table.\n\
+TABLE should be a vector. SYMBOL is used for pointing the translation table out.\n\
+Return index number of the registered translation table.")
+ (symbol, table)
+ Lisp_Object symbol, table;
+{
+ int len = XVECTOR (Vccl_translation_table_vector)->size;
+ int i;
+ Lisp_Object index;
+
+ CHECK_SYMBOL (symbol, 0);
+ CHECK_VECTOR (table, 1);
+
+ for (i = 0; i < len; i++)
+ {
+ Lisp_Object slot = XVECTOR (Vccl_translation_table_vector)->contents[i];
+
+ if (!CONSP (slot))
+ break;
+
+ if (EQ (symbol, XCONS (slot)->car))
+ {
+ index = make_number (i);
+ XCONS (slot)->cdr = table;
+ Fput (symbol, Qccl_translation_table, table);
+ Fput (symbol, Qccl_translation_table_id, index);
+ return index;
+ }
+ }
+
+ if (i == len)
+ {
+ Lisp_Object new_vector = Fmake_vector (make_number (len * 2), Qnil);
+ int j;
+
+ for (j = 0; j < len; j++)
+ XVECTOR (new_vector)->contents[j]
+ = XVECTOR (Vccl_translation_table_vector)->contents[j];
+ Vccl_translation_table_vector = new_vector;
+ }
+
+ index = make_number (i);
+ Fput (symbol, Qccl_translation_table, table);
+ Fput (symbol, Qccl_translation_table_id, index);
+ XVECTOR (Vccl_translation_table_vector)->contents[i] = Fcons (symbol, table);
+ return index;
+}
+
+
+void
syms_of_ccl ()
{
staticpro (&Vccl_program_table);
- Vccl_program_table = Fmake_vector (32, Qnil);
+ Vccl_program_table = Fmake_vector (make_number (32), Qnil);
+
+ Qccl_program = intern ("ccl-program");
+ staticpro (&Qccl_program);
+
+ Qccl_program_idx = intern ("ccl-program-idx");
+ staticpro (&Qccl_program_idx);
+
+ Qccl_translation_table = intern ("ccl-translation-table");
+ staticpro (&Qccl_translation_table);
+
+ Qccl_translation_table_id = intern ("ccl-translation-table-id");
+ staticpro (&Qccl_translation_table_id);
+
+ Qunification_table = intern ("unification-table");
+ staticpro (&Qunification_table);
+
+ Qunification_table_id = intern ("unification-table-id");
+ staticpro (&Qunification_table_id);
+
+ DEFVAR_LISP ("ccl-translation-table-vector", &Vccl_translation_table_vector,
+ "Where is stored translation tables for CCL program.\n\
+Because CCL program can't access these tables except by the index of the vector.");
+ Vccl_translation_table_vector = Fmake_vector (make_number (16), Qnil);
DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist,
"Alist of fontname patterns vs corresponding CCL program.\n\
defsubr (&Sccl_execute);
defsubr (&Sccl_execute_on_string);
defsubr (&Sregister_ccl_program);
+ defsubr (&Sregister_ccl_translation_table);
}
#endif /* emacs */