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 */