diff src/mule-ccl.c @ 4745:0c54de4c4b9d

Resolve the unregistered-CCL-programs-get-garbage-collected problem correctly src/ChangeLog addition: 2009-11-15 Aidan Kehoe <kehoea@parhasard.net> * mule-ccl.c (CCL_CALL_FOR_MAP_INSTRUCTION): Assert that we always have a symbol in this macro. (setup_ccl_program): Ensure we're not allocating unreachable memory in this function; all symbols must have been resolved in a given CCL program before this function is called. (find_ccl_program): New function, return a CCL program with all its symbols resolved if it is valid (possibly allocating memory), Qnil otherwise. (get_ccl_program): New function, exported to other files; call find_ccl_program, and error if it gives nil. (Fccl_program_p): Call find_ccl_program from this function instead of implementing the bulk of it here. (Fccl_execute): Call get_ccl_program instead of implementing the bulk of it here. (Fccl_execute_on_string): Ditto. * mule-ccl.h (Vfont_ccl_encoder_alist): Remove this declaration, it hasn't been used in years. (get_ccl_program): Declare this function. * mule-coding.c (ccl_putprop): Use get_ccl_program on any specified encode or decode CCL program property. (fixed_width_putprop): Ditto. * mule-charset.c (Fmake_charset): Use get_ccl_program on any specified ccl-program. (Fset_charset_ccl_program): Ditto.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 15 Nov 2009 16:53:14 +0000
parents d64f1060cd65
children 27b09b4219b1
line wrap: on
line diff
--- a/src/mule-ccl.c	Sun Nov 15 14:59:53 2009 +0000
+++ b/src/mule-ccl.c	Sun Nov 15 16:53:14 2009 +0000
@@ -627,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))	\
       {								\
@@ -2150,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 (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]);
@@ -2163,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, /*
@@ -2171,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, /*
@@ -2206,10 +2260,17 @@
        (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)
@@ -2229,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,
@@ -2263,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++)
     {