Mercurial > hg > xemacs-beta
diff src/mule-ccl.c @ 5118:e0db3c197671 ben-lisp-object
merge up to latest default branch, doesn't compile yet
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Sat, 26 Dec 2009 21:18:49 -0600 |
parents | 27b09b4219b1 |
children | 0d4c9d0f6a8d |
line wrap: on
line diff
--- a/src/mule-ccl.c Sat Dec 26 00:20:27 2009 -0600 +++ b/src/mule-ccl.c Sat Dec 26 21:18:49 2009 -0600 @@ -29,18 +29,17 @@ #include "charset.h" #include "mule-ccl.h" #include "file-coding.h" +#include "elhash.h" Lisp_Object Qccl_error; /* This contains all code conversion map available to CCL. */ Lisp_Object Vcode_conversion_map_vector; -/* Alist of fontname patterns vs corresponding CCL program. */ -Lisp_Object Vfont_ccl_encoder_alist; - /* This symbol is a property which associates with ccl program vector. - Ex: (get 'ccl-big5-encoder 'ccl-program) returns ccl program vector. */ -Lisp_Object Qccl_program; + Ex: (get 'ccl-big5-encoder 'ccl-program) returns ccl program vector. + Moved to general-slots.h. */ +/* Lisp_Object Qccl_program; */ /* These symbols are properties which associate with code conversion map and their ID respectively. */ @@ -58,6 +57,15 @@ already resolved to index numbers or not. */ Lisp_Object Vccl_program_table; +/* Vector of registered hash tables for translation. */ +Lisp_Object Vtranslation_hash_table_vector; + +/* Return a hash table of id number ID. */ +#define GET_HASH_TABLE(id) \ + (XHASH_TABLE (XCDR(XVECTOR(Vtranslation_hash_table_vector)->contents[(id)]))) +/* Copied from fns.c. */ +#define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1) + /* CCL (Code Conversion Language) is a simple language which has operations on one input buffer, one output buffer, and 7 registers. The syntax of CCL is described in `ccl.el'. Emacs Lisp function @@ -461,6 +469,16 @@ 1:ExtendedCOMMNDRrrRRRrrrXXXXX 2:ARGUMENT(Translation Table ID) */ +/* Translate a character whose code point is reg[rrr] and charset ID is + reg[RRR], into its Unicode code point, which will be written into + reg[rrr]. */ + +#define CCL_MuleToUnicode 0x04 + +/* Translate a Unicode code point, in reg[rrr], into a Mule character, + writing the charset ID into reg[RRR] and the code point into reg[Rrr]. */ + +#define CCL_UnicodeToMule 0x05 /* Iterate looking up MAPs for reg[rrr] starting from the Nth (N = reg[RRR]) MAP until some value is found. @@ -577,7 +595,6 @@ ... N:SEPARATOR_z (< 0) */ - #define MAX_MAP_SET_LEVEL 30 typedef struct @@ -610,6 +627,9 @@ #define CCL_CALL_FOR_MAP_INSTRUCTION(symbol, ret_ic) \ do { \ struct ccl_program called_ccl; \ + /* We shouldn't ever call setup_ccl_program on a vector in \ + this context: */ \ + text_checking_assert (SYMBOLP (symbol)); \ if (stack_idx >= 256 \ || (setup_ccl_program (&called_ccl, (symbol)) != 0)) \ { \ @@ -617,14 +637,17 @@ { \ ccl_prog = ccl_prog_stack_struct[0].ccl_prog; \ ic = ccl_prog_stack_struct[0].ic; \ + eof_ic = ccl_prog_stack_struct[0].eof_ic; \ } \ CCL_INVALID_CMD; \ } \ ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; \ ccl_prog_stack_struct[stack_idx].ic = (ret_ic); \ + ccl_prog_stack_struct[stack_idx].eof_ic = eof_ic; \ stack_idx++; \ ccl_prog = called_ccl.prog; \ ic = CCL_HEADER_MAIN; \ + eof_ic = XINT (ccl_prog[CCL_HEADER_EOF]); \ /* The "if (1)" prevents warning \ "end-of loop code not reached" */ \ if (1) goto ccl_repeat; \ @@ -641,6 +664,19 @@ set reg[RRR] to -1. */ +#define CCL_LookupIntConstTbl 0x13 /* Lookup multibyte character by + integer key. Afterwards R7 set + to 1 iff lookup succeeded. + 1:ExtendedCOMMNDRrrRRRXXXXXXXX + 2:ARGUMENT(Hash table ID) */ + +#define CCL_LookupCharConstTbl 0x14 /* Lookup integer by multibyte + character key. Afterwards R7 set + to 1 iff lookup succeeded. + 1:ExtendedCOMMNDRrrRRRrrrXXXXX + 2:ARGUMENT(Hash table ID) */ + + /* CCL arithmetic/logical operators. */ #define CCL_PLUS 0x00 /* X = Y + Z */ #define CCL_MINUS 0x01 /* X = Y - Z */ @@ -763,7 +799,7 @@ { \ for (i = 0; i < (len); i++) \ { \ - ch = ((XINT (ccl_prog[ic + (i / 3)])) \ + ch = ((XCHAR_OR_INT (ccl_prog[ic + (i / 3)])) \ >> ((2 - (i % 3)) * 8)) & 0xFF; \ if (ch == '\n') \ { \ @@ -792,7 +828,7 @@ { \ for (i = 0; i < (len); i++) \ { \ - ch = ((XINT (ccl_prog[ic + (i / 3)])) \ + ch = ((XCHAR_OR_INT (ccl_prog[ic + (i / 3)])) \ >> ((2 - (i % 3)) * 8)) & 0xFF; \ if (!ichar_multibyte_p(ch)) \ { \ @@ -827,7 +863,7 @@ } while (0) #define POSSIBLE_LEADING_BYTE_P(leading_byte) \ - ((leading_byte > MIN_LEADING_BYTE) && \ + ((leading_byte >= MIN_LEADING_BYTE) && \ (leading_byte - MIN_LEADING_BYTE) < NUM_LEADING_BYTES) /* Set C to the character code made from CHARSET and CODE. This is @@ -837,26 +873,45 @@ CODE to that invalid byte. */ /* On XEmacs, TranslateCharacter is not supported. Thus, this - macro is not used. */ -#if 0 + macro is only used in the MuleToUnicode transformation. */ #define CCL_MAKE_CHAR(charset, code, c) \ do { \ - if ((charset) == CHARSET_ASCII) \ - (c) = (code) & 0xFF; \ - else if (CHARSET_DEFINED_P (charset) \ - && ((code) & 0x7F) >= 32 \ + \ + if (!POSSIBLE_LEADING_BYTE_P(charset)) \ + CCL_INVALID_CMD; \ + \ + if ((charset) == LEADING_BYTE_ASCII) \ + { \ + c = (code) & 0xFF; \ + } \ + else if ((charset) == LEADING_BYTE_CONTROL_1) \ + { \ + c = ((code) & 0x1F) + 0x80; \ + } \ + else if (!NILP(charset_by_leading_byte(charset)) \ + && ((code) >= 32) \ && ((code) < 256 || ((code >> 7) & 0x7F) >= 32)) \ { \ - int c1 = (code) & 0x7F, c2 = 0; \ + int c1, c2 = 0; \ \ - if ((code) >= 256) \ - c2 = c1, c1 = ((code) >> 7) & 0x7F; \ - (c) = make_ichar (charset, c1, c2); \ + if ((code) < 256) \ + { \ + c1 = (code) & 0x7F; \ + c2 = 0; \ + } \ + else \ + { \ + c1 = ((code) >> 7) & 0x7F; \ + c2 = (code) & 0x7F; \ + } \ + c = make_ichar (charset_by_leading_byte(charset), \ + c1, c2); \ } \ else \ - (c) = (code) & 0xFF; \ - } while (0) -#endif + { \ + c = (code) & 0xFF; \ + } \ + } while (0) /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting @@ -869,7 +924,7 @@ #ifdef CCL_DEBUG #define CCL_DEBUG_BACKTRACE_LEN 256 -int ccl_backtrace_table[CCL_BACKTRACE_TABLE]; +int ccl_backtrace_table[CCL_DEBUG_BACKTRACE_LEN]; int ccl_backtrace_idx; #endif @@ -877,6 +932,7 @@ { Lisp_Object *ccl_prog; /* Pointer to an array of CCL code. */ int ic; /* Instruction Counter. */ + int eof_ic; /* Instruction Counter to jump on EOF. */ }; /* For the moment, we only support depth 256 of stack. */ @@ -901,8 +957,10 @@ int stack_idx = ccl->stack_idx; /* Instruction counter of the current CCL code. */ int this_ic = 0; + int eof_ic = ccl->eof_ic; + int eof_hit = 0; - if (ic >= ccl->eof_ic) + if (ic >= eof_ic) ic = CCL_HEADER_MAIN; if (ccl->buf_magnification ==0) /* We can't produce any bytes. */ @@ -937,7 +995,7 @@ } this_ic = ic; - code = XINT (ccl_prog[ic]); ic++; + code = XCHAR_OR_INT (ccl_prog[ic]); ic++; field1 = code >> 8; field2 = (code & 0xFF) >> 5; @@ -958,7 +1016,7 @@ break; case CCL_SetConst: /* 00000000000000000000rrrXXXXX */ - reg[rrr] = XINT (ccl_prog[ic]); + reg[rrr] = XCHAR_OR_INT (ccl_prog[ic]); ic++; break; @@ -969,7 +1027,7 @@ but the left one was already there so clearly the intention was an unsigned comparison. --ben */ if ((unsigned int) i < (unsigned int) j) - reg[rrr] = XINT (ccl_prog[ic + i]); + reg[rrr] = XCHAR_OR_INT (ccl_prog[ic + i]); ic += j; break; @@ -997,13 +1055,13 @@ break; case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */ - i = XINT (ccl_prog[ic]); + i = XCHAR_OR_INT (ccl_prog[ic]); CCL_WRITE_CHAR (i); ic += ADDR; break; case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */ - i = XINT (ccl_prog[ic]); + i = XCHAR_OR_INT (ccl_prog[ic]); CCL_WRITE_CHAR (i); ic++; CCL_READ_CHAR (reg[rrr]); @@ -1011,7 +1069,7 @@ break; case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */ - j = XINT (ccl_prog[ic]); + j = XCHAR_OR_INT (ccl_prog[ic]); ic++; CCL_WRITE_STRING (j); ic += ADDR - 1; @@ -1019,11 +1077,11 @@ case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */ i = reg[rrr]; - j = XINT (ccl_prog[ic]); + j = XCHAR_OR_INT (ccl_prog[ic]); /* #### see comment at CCL_SetArray */ if ((unsigned int) i < (unsigned int) j) { - i = XINT (ccl_prog[ic + 1 + i]); + i = XCHAR_OR_INT (ccl_prog[ic + 1 + i]); CCL_WRITE_CHAR (i); } ic += j + 2; @@ -1042,9 +1100,9 @@ case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */ /* #### see comment at CCL_SetArray */ if ((unsigned int) reg[rrr] < (unsigned int) field1) - ic += XINT (ccl_prog[ic + reg[rrr]]); + ic += XCHAR_OR_INT (ccl_prog[ic + reg[rrr]]); else - ic += XINT (ccl_prog[ic + field1]); + ic += XCHAR_OR_INT (ccl_prog[ic + field1]); break; case CCL_ReadRegister: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */ @@ -1052,7 +1110,7 @@ { CCL_READ_CHAR (reg[rrr]); if (!field1) break; - code = XINT (ccl_prog[ic]); ic++; + code = XCHAR_OR_INT (ccl_prog[ic]); ic++; field1 = code >> 8; field2 = (code & 0xFF) >> 5; } @@ -1061,7 +1119,7 @@ case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */ rrr = 7; i = reg[RRR]; - j = XINT (ccl_prog[ic]); + j = XCHAR_OR_INT (ccl_prog[ic]); op = field1 >> 6; jump_address = ic + 1; goto ccl_set_expr; @@ -1072,7 +1130,7 @@ i = reg[rrr]; CCL_WRITE_CHAR (i); if (!field1) break; - code = XINT (ccl_prog[ic]); ic++; + code = XCHAR_OR_INT (ccl_prog[ic]); ic++; field1 = code >> 8; field2 = (code & 0xFF) >> 5; } @@ -1095,7 +1153,7 @@ following code. */ if (rrr) { - prog_id = XINT (ccl_prog[ic]); + prog_id = XCHAR_OR_INT (ccl_prog[ic]); ic++; } else @@ -1112,15 +1170,18 @@ { ccl_prog = ccl_prog_stack_struct[0].ccl_prog; ic = ccl_prog_stack_struct[0].ic; + eof_ic = ccl_prog_stack_struct[0].eof_ic; } CCL_INVALID_CMD; } ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; ccl_prog_stack_struct[stack_idx].ic = ic; + ccl_prog_stack_struct[stack_idx].eof_ic = eof_ic; stack_idx++; ccl_prog = XVECTOR (XVECTOR (slot)->contents[1])->contents; ic = CCL_HEADER_MAIN; + eof_ic = XINT (ccl_prog[CCL_HEADER_EOF]); } break; @@ -1139,7 +1200,7 @@ /* #### see comment at CCL_SetArray */ if ((unsigned int) i < (unsigned int) field1) { - j = XINT (ccl_prog[ic + i]); + j = XCHAR_OR_INT (ccl_prog[ic + i]); CCL_WRITE_CHAR (j); } ic += field1; @@ -1151,6 +1212,9 @@ stack_idx--; ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog; ic = ccl_prog_stack_struct[stack_idx].ic; + eof_ic = ccl_prog_stack_struct[stack_idx].eof_ic; + if (eof_hit) + ic = eof_ic; break; } if (src) @@ -1161,7 +1225,7 @@ CCL_SUCCESS; case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */ - i = XINT (ccl_prog[ic]); + i = XCHAR_OR_INT (ccl_prog[ic]); ic++; op = field1 >> 6; goto ccl_expr_self; @@ -1198,7 +1262,7 @@ case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */ i = reg[RRR]; - j = XINT (ccl_prog[ic]); + j = XCHAR_OR_INT (ccl_prog[ic]); op = field1 >> 6; jump_address = ++ic; goto ccl_set_expr; @@ -1214,9 +1278,9 @@ CCL_READ_CHAR (reg[rrr]); case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */ i = reg[rrr]; - op = XINT (ccl_prog[ic]); + op = XCHAR_OR_INT (ccl_prog[ic]); jump_address = ic++ + ADDR; - j = XINT (ccl_prog[ic]); + j = XCHAR_OR_INT (ccl_prog[ic]); ic++; rrr = 7; goto ccl_set_expr; @@ -1225,9 +1289,9 @@ CCL_READ_CHAR (reg[rrr]); case CCL_JumpCondExprReg: i = reg[rrr]; - op = XINT (ccl_prog[ic]); + op = XCHAR_OR_INT (ccl_prog[ic]); jump_address = ic++ + ADDR; - j = reg[XINT (ccl_prog[ic])]; + j = reg[XCHAR_OR_INT (ccl_prog[ic])]; ic++; rrr = 7; @@ -1329,7 +1393,7 @@ if ((src + 1) >= src_end) goto ccl_read_multibyte_character_suspend; reg[RRR] = *src++; - reg[rrr] = (*src++ & 0x7F); + reg[rrr] = (*src++ & 0xFF); } else if (i == PRE_LEADING_BYTE_PRIVATE_2) { @@ -1349,10 +1413,32 @@ break; ccl_read_multibyte_character_suspend: + if (src <= src_end && ccl->last_block) + { + /* #### Unclear when this happens. GNU use + CHARSET_8_BIT_CONTROL here, which we can't. */ + if (i < 0x80) + { + reg[RRR] = LEADING_BYTE_ASCII; + reg[rrr] = i; + } + else if (i < 0xA0) + { + reg[RRR] = LEADING_BYTE_CONTROL_1; + reg[rrr] = i - 0xA0; + } + else + { + reg[RRR] = LEADING_BYTE_LATIN_ISO8859_1; + reg[rrr] = i & 0x7F; + } + break; + } src--; if (ccl->last_block) { - ic = ccl->eof_ic; + ic = eof_ic; + eof_hit = 1; goto ccl_repeat; } else @@ -1365,14 +1451,14 @@ if (i == LEADING_BYTE_ASCII) i = reg[rrr] & 0xFF; else if (LEADING_BYTE_CONTROL_1 == i) - i = ((reg[rrr] & 0xFF) - 0xA0); + i = ((reg[rrr] & 0x1F) + 0x80); else if (POSSIBLE_LEADING_BYTE_P(i) && !NILP(charset_by_leading_byte(i))) { if (XCHARSET_DIMENSION (charset_by_leading_byte (i)) == 1) i = (((i - FIELD2_TO_OFFICIAL_LEADING_BYTE) << 7) | (reg[rrr] & 0x7F)); - else if (i < MAX_LEADING_BYTE_OFFICIAL_2) + else if (i <= MAX_LEADING_BYTE_OFFICIAL_2) i = ((i - FIELD1_TO_OFFICIAL_LEADING_BYTE) << 14) | reg[rrr]; else @@ -1392,9 +1478,9 @@ case CCL_TranslateCharacter: #if 0 - /* XEmacs does not have translate_char, and its - equivalent nor. We do nothing on this operation. */ - CCL_MAKE_CHAR (reg[RRR], reg[rrr], i); + /* XEmacs does not have translate_char, nor an + equivalent. We do nothing on this operation. */ + CCL_MAKE_CHAR(reg[RRR], reg[rrr], op); op = translate_char (GET_TRANSLATION_TABLE (reg[Rrr]), i, -1, 0, 0); SPLIT_CHAR (op, reg[RRR], i, j); @@ -1409,7 +1495,7 @@ #if 0 /* XEmacs does not have translate_char or an equivalent. We do nothing on this operation. */ - op = XINT (ccl_prog[ic]); /* table */ + op = XCHAR_OR_INT (ccl_prog[ic]); /* table */ ic++; CCL_MAKE_CHAR (reg[RRR], reg[rrr], i); op = translate_char (GET_TRANSLATION_TABLE (op), i, -1, 0, 0); @@ -1421,12 +1507,115 @@ #endif break; + case CCL_MuleToUnicode: + { + Lisp_Object ucs; + + CCL_MAKE_CHAR (reg[rrr], reg[RRR], op); + + ucs = Fchar_to_unicode(make_char(op)); + + if (NILP(ucs)) + { + /* Uhh, char-to-unicode doesn't return nil at the + moment, only ever -1. */ + reg[rrr] = 0xFFFD; /* REPLACEMENT CHARACTER */ + } + else + { + reg[rrr] = XCHAR_OR_INT(ucs); + if (-1 == reg[rrr]) + { + reg[rrr] = 0xFFFD; /* REPLACEMENT CHARACTER */ + } + } + break; + } + + case CCL_UnicodeToMule: + { + Lisp_Object scratch; + + scratch = Funicode_to_char(make_int(reg[rrr]), Qnil); + + if (!NILP(scratch)) + { + op = XCHAR(scratch); + BREAKUP_ICHAR (op, scratch, i, j); + reg[RRR] = XCHARSET_ID(scratch); + + if (j != 0) + { + i = (i << 7) | j; + } + + reg[rrr] = i; + } + else + { + reg[rrr] = reg[RRR] = 0; + } + break; + } + + case CCL_LookupIntConstTbl: + op = XCHAR_OR_INT (ccl_prog[ic]); /* table */ + ic++; + { + struct Lisp_Hash_Table *h = GET_HASH_TABLE (op); + htentry *e = find_htentry(make_int (reg[RRR]), h); + Lisp_Object scratch; + + if (!HTENTRY_CLEAR_P(e)) + { + op = XCHARVAL (e->value); + if (!valid_ichar_p(op)) + { + CCL_INVALID_CMD; + } + + BREAKUP_ICHAR (op, scratch, i, j); + reg[RRR] = XCHARSET_ID(scratch); + + if (j != 0) + { + i = (i << 7) | j; + } + reg[rrr] = i; + reg[7] = 1; /* r7 true for success */ + } + else + reg[7] = 0; + } + break; + + case CCL_LookupCharConstTbl: + op = XCHAR_OR_INT (ccl_prog[ic]); /* table */ + ic++; + CCL_MAKE_CHAR (reg[RRR], reg[rrr], i); + { + struct Lisp_Hash_Table *h = GET_HASH_TABLE (op); + htentry *e = find_htentry(make_int(i), h); + + if (!HTENTRY_CLEAR_P(e)) + { + if (!INTP (e->value)) + CCL_INVALID_CMD; + reg[RRR] = XCHAR_OR_INT (e->value); + reg[7] = 1; /* r7 true for success */ + } + else + reg[7] = 0; + } + break; + + case CCL_IterateMultipleMap: { Lisp_Object map, content, attrib, value; int point, size, fin_ic; - j = XINT (ccl_prog[ic++]); /* number of maps. */ + j = XCHAR_OR_INT (ccl_prog[ic++]); /* number of maps. */ fin_ic = ic + j; op = reg[rrr]; if ((j > reg[RRR]) && (j >= 0)) @@ -1444,7 +1633,7 @@ for (;i < j;i++) { size = XVECTOR (Vcode_conversion_map_vector)->size; - point = XINT (ccl_prog[ic++]); + point = XCHAR_OR_INT (ccl_prog[ic++]); if (point >= size) continue; map = XVECTOR (Vcode_conversion_map_vector)->contents[point]; @@ -1490,7 +1679,7 @@ else if (INTP (content)) { reg[RRR] = i; - reg[rrr] = XINT(content); + reg[rrr] = XCHAR_OR_INT(content); break; } else if (EQ (content, Qt) || EQ (content, Qlambda)) @@ -1541,7 +1730,7 @@ stack_idx_of_map_multiple = 0; map_set_rest_length = - XINT (ccl_prog[ic++]); /* number of maps and separators. */ + XCHAR_OR_INT (ccl_prog[ic++]); /* number of maps and separators. */ fin_ic = ic + map_set_rest_length; op = reg[rrr]; @@ -1609,7 +1798,7 @@ do { for (;map_set_rest_length > 0;i++, ic++, map_set_rest_length--) { - point = XINT(ccl_prog[ic]); + point = XCHAR_OR_INT(ccl_prog[ic]); if (point < 0) { /* +1 is for including separator. */ @@ -1670,7 +1859,7 @@ reg[RRR] = i; if (INTP (content)) { - op = XINT (content); + op = XCHAR_OR_INT (content); i += map_set_rest_length - 1; ic += map_set_rest_length - 1; POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); @@ -1728,7 +1917,7 @@ { Lisp_Object map, attrib, value, content; int size, point; - j = XINT (ccl_prog[ic++]); /* map_id */ + j = XCHAR_OR_INT (ccl_prog[ic++]); /* map_id */ op = reg[rrr]; if (j >= XVECTOR (Vcode_conversion_map_vector)->size) { @@ -1761,7 +1950,7 @@ if (NILP (content)) reg[RRR] = -1; else if (INTP (content)) - reg[rrr] = XINT (content); + reg[rrr] = XCHAR_OR_INT (content); else if (EQ (content, Qt)); else if (CONSP (content)) { @@ -1864,7 +2053,9 @@ for (i = 0; i < veclen; i++) { contents = XVECTOR (result)->contents[i]; - if (INTP (contents)) + /* XEmacs change; accept characters as well as integers, on the basis + that most CCL code written doesn't make a distinction. */ + if (INTP (contents) || CHARP(contents)) continue; else if (CONSP (contents) && SYMBOLP (XCAR (contents)) @@ -1962,9 +2153,20 @@ xzero (*ccl); /* XEmacs change */ if (! NILP (ccl_prog)) { - ccl_prog = ccl_get_compiled_code (ccl_prog); + Lisp_Object new_prog = ccl_get_compiled_code (ccl_prog); + + if (VECTORP (ccl_prog)) + { + /* Make sure we're not allocating unreachable memory in this + function: */ + assert (EQ (ccl_prog, new_prog)); + } + + ccl_prog = new_prog; + if (! VECTORP (ccl_prog)) return -1; + ccl->size = XVECTOR_LENGTH (ccl_prog); ccl->prog = XVECTOR_DATA (ccl_prog); ccl->eof_ic = XINT (XVECTOR_DATA (ccl_prog)[CCL_HEADER_EOF]); @@ -1975,6 +2177,59 @@ return 0; } +static Lisp_Object +find_ccl_program (Lisp_Object object, int *unresolved_symbols) +{ + struct ccl_program test_ccl; + + if (NULL != unresolved_symbols) + { + *unresolved_symbols = 0; + } + + if (VECTORP (object)) + { + object = resolve_symbol_ccl_program (object); + if (EQ (Qt, object)) + { + if (NULL != unresolved_symbols) + { + *unresolved_symbols = 1; + } + return Qnil; + } + } + else if (!SYMBOLP (object)) + { + return Qnil; + } + + if (setup_ccl_program (&test_ccl, object) < 0) + { + return Qnil; + } + + return object; +} + +Lisp_Object +get_ccl_program (Lisp_Object object) +{ + int unresolved_symbols = 0; + Lisp_Object val = find_ccl_program (object, &unresolved_symbols); + + if (unresolved_symbols) + { + invalid_argument ("Unresolved symbol(s) in CCL program", object); + } + else if (NILP (val)) + { + invalid_argument ("Invalid CCL program", object); + } + + return val; +} + #ifdef emacs DEFUN ("ccl-program-p", Fccl_program_p, 1, 1, 0, /* @@ -1983,20 +2238,7 @@ */ (object)) { - Lisp_Object val; - - if (VECTORP (object)) - { - val = resolve_symbol_ccl_program (object); - return (VECTORP (val) ? Qt : Qnil); - } - if (!SYMBOLP (object)) - return Qnil; - - val = Fget (object, Qccl_program_idx, Qnil); - return ((! NATNUMP (val) - || XINT (val) >= XVECTOR_LENGTH (Vccl_program_table)) - ? Qnil : Qt); + return NILP (find_ccl_program (object, NULL)) ? Qnil : Qt; } DEFUN ("ccl-execute", Fccl_execute, 2, 2, 0, /* @@ -2018,18 +2260,25 @@ (ccl_prog, reg)) { struct ccl_program ccl; + struct gcpro gcpro1; int i; - if (setup_ccl_program (&ccl, ccl_prog) < 0) - syntax_error ("Invalid CCL program", Qunbound); + ccl_prog = get_ccl_program (ccl_prog); + /* get_ccl_program may have consed. GCPROing shouldn't be necessary at the + moment, but maybe someday CCL will call Lisp: */ + GCPRO1 (ccl_prog); + + i = setup_ccl_program (&ccl, ccl_prog); + + text_checking_assert (i >= 0); CHECK_VECTOR (reg); if (XVECTOR_LENGTH (reg) != 8) syntax_error ("Length of vector REGISTERS is not 8", Qunbound); for (i = 0; i < 8; i++) - ccl.reg[i] = (INTP (XVECTOR_DATA (reg)[i]) - ? XINT (XVECTOR_DATA (reg)[i]) + ccl.reg[i] = (INTP (XVECTOR_DATA (reg)[i]) || CHARP (XVECTOR_DATA (reg)[i]) + ? XCHAR_OR_INT (XVECTOR_DATA (reg)[i]) : 0); ccl_driver (&ccl, (const unsigned char *)0, @@ -2041,7 +2290,8 @@ for (i = 0; i < 8; i++) XVECTOR (reg)->contents[i] = make_int (ccl.reg[i]); - return Qnil; + + RETURN_UNGCPRO (Qnil); } DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, @@ -2075,17 +2325,19 @@ struct ccl_program ccl; int i, produced; unsigned_char_dynarr *outbuf; - struct gcpro gcpro1, gcpro2; + struct gcpro gcpro1, gcpro2, gcpro3; - if (setup_ccl_program (&ccl, ccl_prog) < 0) - syntax_error ("Invalid CCL program", Qunbound); + ccl_prog = get_ccl_program (ccl_prog); + i = setup_ccl_program (&ccl, ccl_prog); + + text_checking_assert (i >= 0); CHECK_VECTOR (status); if (XVECTOR (status)->size != 9) syntax_error ("Length of vector STATUS is not 9", Qunbound); CHECK_STRING (string); - GCPRO2 (status, string); + GCPRO3 (status, string, ccl_prog); for (i = 0; i < 8; i++) { @@ -2093,10 +2345,13 @@ XVECTOR_DATA (status)[i] = make_int (0); if (INTP (XVECTOR_DATA (status)[i])) ccl.reg[i] = XINT (XVECTOR_DATA (status)[i]); + if (CHARP (XVECTOR_DATA (status)[i])) + ccl.reg[i] = XCHAR (XVECTOR_DATA (status)[i]); } - if (INTP (XVECTOR (status)->contents[i])) + if (INTP (XVECTOR (status)->contents[i]) || + CHARP (XVECTOR (status)->contents[i])) { - i = XINT (XVECTOR_DATA (status)[8]); + i = XCHAR_OR_INT (XVECTOR_DATA (status)[8]); if (ccl.ic < i && i < ccl.size) ccl.ic = i; } @@ -2268,9 +2523,16 @@ void vars_of_mule_ccl (void) { + staticpro (&Vccl_program_table); Vccl_program_table = Fmake_vector (make_int (32), Qnil); +#ifdef DEBUG_XEMACS + DEFVAR_LISP ("ccl-program-table", + &Vccl_program_table /* +Vector containing all registered CCL programs. +*/ ); +#endif DEFSYMBOL (Qccl_program); DEFSYMBOL (Qccl_program_idx); DEFSYMBOL (Qcode_conversion_map); @@ -2281,19 +2543,15 @@ */ ); Vcode_conversion_map_vector = Fmake_vector (make_int (16), Qnil); - DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist /* -Alist of fontname patterns vs corresponding CCL program. -Each element looks like (REGEXP . CCL-CODE), - where CCL-CODE is a compiled CCL program. -When a font whose name matches REGEXP is used for displaying a character, - CCL-CODE is executed to calculate the code point in the font - from the charset number and position code(s) of the character which are set - in CCL registers R0, R1, and R2 before the execution. -The code point in the font is set in CCL registers R1 and R2 - when the execution terminated. -If the font is single-byte font, the register R2 is not used. + DEFVAR_LISP ("translation-hash-table-vector", + &Vtranslation_hash_table_vector /* +Vector containing all translation hash tables ever defined. +Comprises pairs (SYMBOL . TABLE) where SYMBOL and TABLE were set up by calls +to `define-translation-hash-table'. The vector is indexed by the table id +used by CCL. */ ); - Vfont_ccl_encoder_alist = Qnil; + Vtranslation_hash_table_vector = Qnil; + } #endif /* emacs */