merge the branch mltk

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4745 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 98 insertions, 114 deletions

diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c
index 40adccf2d..236dc299a 100644
--- a/otherlibs/labltk/support/cltkEval.c
+++ b/otherlibs/labltk/support/cltkEval.c
@@ -1,22 +1,23 @@
-/*************************************************************************/
-/*                                                                       */
-/*                Objective Caml LablTk library                          */
-/*                                                                       */
-/*         Francois Rouaix, Francois Pessaux and Jun Furuse              */
-/*               projet Cristal, INRIA Rocquencourt                      */
-/*            Jacques Garrigue, Kyoto University RIMS                    */
-/*                                                                       */
-/*   Copyright 1999 Institut National de Recherche en Informatique et    */
-/*   en Automatique and Kyoto University.  All rights reserved.          */
-/*   This file is distributed under the terms of the GNU Library         */
-/*   General Public License, with the special exception on linking       */
-/*   described in file ../../../LICENSE.                                 */
-/*                                                                       */
-/*************************************************************************/
+/***********************************************************************/
+/*                                                                     */
+/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                                                                     */
+/*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
+/*               projet Cristal, INRIA Rocquencourt                    */
+/*            Jacques Garrigue, Kyoto University RIMS                  */
+/*                                                                     */
+/*  Copyright 2002 Institut National de Recherche en Informatique et   */
+/*  en Automatique and Kyoto University.  All rights reserved.         */
+/*  This file is distributed under the terms of the GNU Library        */
+/*  General Public License, with the special exception on linking      */
+/*  described in file LICENSE found in the Objective Caml source tree. */
+/*                                                                     */
+/***********************************************************************/
 
 /* $Id$ */
 
 #include <stdlib.h>
+#include <string.h>
 
 #include <tcl.h>
 #include <tk.h>
@@ -29,26 +30,26 @@
 #include "camltk.h"
 
 /* The Tcl interpretor */
-Tcl_Interp *cltclinterp = NULL;
+CAMLprim Tcl_Interp *cltclinterp = NULL;
 
 /* Copy a list of strings from the C heap to Caml */
 value copy_string_list(int argc, char **argv)
 {
-  value res;
+  CAMLparam0();
+  CAMLlocal3( res, oldres, str );
   int i;
-  value oldres = Val_unit, str = Val_unit;
-
-  Begin_roots2 (oldres, str);
-    res = Val_int(0); /* [] */
-    for (i = argc-1; i >= 0; i--) {
-      oldres = res;
-      str = copy_string(argv[i]);
-      res = alloc(2, 0);
-      Field(res, 0) = str;
-      Field(res, 1) = oldres;
-    }
-  End_roots();
-  return res;
+  oldres = Val_unit;
+  str = Val_unit;
+
+  res = Val_int(0); /* [] */
+  for (i = argc-1; i >= 0; i--) {
+    oldres = res;
+    str = tcl_string_to_caml(argv[i]);
+    res = alloc(2, 0);
+    Field(res, 0) = str;
+    Field(res, 1) = oldres;
+  }
+  CAMLreturn(res);
 }
 
 /*
@@ -68,13 +69,13 @@ CAMLprim value camltk_tcl_eval(value str)
    * leak
    */
   Tcl_ResetResult(cltclinterp);
-  cmd = string_to_c(str);
+  cmd = caml_string_to_tcl(str);
   code = Tcl_Eval(cltclinterp, cmd);
   stat_free(cmd);
 
   switch (code) {
   case TCL_OK:
-    return copy_string(cltclinterp->result);
+    return tcl_string_to_caml(cltclinterp->result);
   case TCL_ERROR:
     tk_error(cltclinterp->result);
   default:  /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
@@ -104,7 +105,7 @@ int argv_size(value v)
   case 0:                       /* TkToken */
     return 1;
   case 1:                       /* TkTokenList */
-    { int n;
+    { int n = 0;
       value l;
       for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1))
         n+=argv_size(Field(l,0));
@@ -112,23 +113,11 @@ int argv_size(value v)
     }
   case 2:                       /* TkQuote */
     return 1;
-  default:                      /* should not happen */
-    Assert(0);
-    return 0;
+  default:
+    tk_error("argv_size: illegal tag");
   }
 }
 
-/* 
- * Memory of allocated Tcl lists.
- * We should not need more than MAX_LIST
- */
-#define MAX_LIST 256
-static char *tcllists[MAX_LIST];
-
-static int startfree = 0;
-/* If size is lower, do not allocate */
-static char *quotedargv[16];
-
 /* Fill a preallocated vector arguments, doing expansion and all.
  * Assumes Tcl will 
  *  not tamper with our strings
@@ -136,34 +125,35 @@ static char *quotedargv[16];
  */
 int fill_args (char **argv, int where, value v)
 {
+  value l;
+  
   switch (Tag_val(v)) {
   case 0:
-    argv[where] = String_val(Field(v,0));
+    argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */
     return (where + 1);
   case 1:
-    { value l;
-      for (l=Field(v,0); Is_block(l); l=Field(l,1))
-        where = fill_args(argv,where,Field(l,0));
-      return where;
-    }
+    for (l=Field(v,0); Is_block(l); l=Field(l,1))
+      where = fill_args(argv,where,Field(l,0));
+    return where;
   case 2:
     { char **tmpargv;
+      char *merged;
+      int i;
       int size = argv_size(Field(v,0));
-      if (size < 16)
-        tmpargv = &quotedargv[0];
-      else
-        tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
+      tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
       fill_args(tmpargv,0,Field(v,0));
       tmpargv[size] = NULL;
-      argv[where] = Tcl_Merge(size,tmpargv);
-      tcllists[startfree++] = argv[where]; /* so we can free it later */
-      if (size >= 16) 
-        stat_free((char *)tmpargv);
+      merged = Tcl_Merge(size,tmpargv);
+      for(i = 0 ; i<size; i++){ stat_free(tmpargv[i]); }
+      stat_free((char *)tmpargv);
+      /* must be freed by stat_free */
+      argv[where] = (char*)stat_alloc(strlen(merged)+1); 
+      strcpy(argv[where], merged);
+      Tcl_Free(merged);
       return (where + 1);
     }
-  default:                      /* should not happen */
-    Assert(0);
-    return 0;
+  default:
+    tk_error("fill_args: illegal tag");
   }
 }
 
@@ -172,10 +162,9 @@ CAMLprim value camltk_tcl_direct_eval(value v)
 {
   int i;
   int size;                     /* size of argv */
-  char **argv;
+  char **argv, **allocated;
   int result;
   Tcl_CmdInfo info;
-  int wherewasi,whereami;       /* positions in tcllists array */
 
   CheckInit();
 
@@ -186,76 +175,71 @@ CAMLprim value camltk_tcl_direct_eval(value v)
   /* +2: one slot for NULL
          one slot for "unknown" if command not found */
   argv = (char **)stat_alloc((size + 2) * sizeof(char *));
+  allocated = (char **)stat_alloc(size * sizeof(char *));
 
-  wherewasi = startfree; /* should be zero except when nested calls */
-  Assert(startfree < MAX_LIST);
-
-  /* Copy */
+  /* Copy -- argv[i] must be freed by stat_free */
   {
     int where;
-    for(i=0, where=0;i<Wosize_val(v);i++)
+    for(i=0, where=0;i<Wosize_val(v);i++){
       where = fill_args(argv,where,Field(v,i));
+    }
+    if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); }
+    for(i=0; i<where; i++){ allocated[i] = argv[i]; } 
     argv[size] = NULL;
     argv[size + 1] = NULL;
   }
 
-  Begin_roots_block ((value *) argv, size + 2);
-
-  whereami = startfree;
-
-    /* Eval */
-    Tcl_ResetResult(cltclinterp);
-    if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */
+  /* Eval */
+  Tcl_ResetResult(cltclinterp);
+  if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */
 #if (TCL_MAJOR_VERSION >= 8)
-      /* info.proc might be a NULL pointer
-       * We should probably attempt an Obj invocation, but the following quick
-       * hack is easier.
-       */
-      if (info.proc == NULL) {
-        Tcl_DString buf;
-        char *string;
-        Tcl_DStringInit(&buf);
-        Tcl_DStringAppend(&buf, argv[0], -1);
-        for (i=1; i<size; i++) {
-          Tcl_DStringAppend(&buf, " ", -1);
-          Tcl_DStringAppend(&buf, argv[i], -1);
-        }
-        /* fprintf(stderr,"80 compat: %s\n", argv[0]); */
-        result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf));
-        Tcl_DStringFree(&buf);
+    /* info.proc might be a NULL pointer
+     * We should probably attempt an Obj invocation, but the following quick
+     * hack is easier.
+     */
+    if (info.proc == NULL) {
+      Tcl_DString buf;
+      char *string;
+      Tcl_DStringInit(&buf);
+      Tcl_DStringAppend(&buf, argv[0], -1);
+      for (i=1; i<size; i++) {
+	Tcl_DStringAppend(&buf, " ", -1);
+	Tcl_DStringAppend(&buf, argv[i], -1);
       }
-      else
-        result = (*info.proc)(info.clientData,cltclinterp,size,argv);
-#else
+      result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf));
+      Tcl_DStringFree(&buf);
+    } else {
       result = (*info.proc)(info.clientData,cltclinterp,size,argv);
+    }
+#else
+    result = (*info.proc)(info.clientData,cltclinterp,size,argv);
 #endif
-    } else {/* implement the autoload stuff */
-      if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */
-        for (i = size; i >= 0; i--)
-          argv[i+1] = argv[i];
-        argv[0] = "unknown";
-        result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
-      } else { /* ah, it isn't there at all */
-        result = TCL_ERROR;
-        Tcl_AppendResult(cltclinterp, "Unknown command \"", 
-                         argv[0], "\"", NULL);
-      }
+  } else { /* implement the autoload stuff */
+    if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */
+      for (i = size; i >= 0; i--)
+	argv[i+1] = argv[i];
+      argv[0] = "unknown";
+      result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
+    } else { /* ah, it isn't there at all */
+      result = TCL_ERROR;
+      Tcl_AppendResult(cltclinterp, "Unknown command \"", 
+		       argv[0], "\"", NULL);
     }
-  End_roots ();
+  }
 
   /* Free the various things we allocated */
+  for(i=0; i< size; i ++){
+    stat_free((char *) allocated[i]);
+  }
   stat_free((char *)argv);
-  for (i=wherewasi; i<whereami; i++)
-    free(tcllists[i]);
-  startfree = wherewasi;
+  stat_free((char *)allocated);
   
   switch (result) {
   case TCL_OK:
-    return copy_string (cltclinterp->result);
+    return tcl_string_to_caml (cltclinterp->result);
   case TCL_ERROR:
     tk_error(cltclinterp->result);
   default:  /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
     tk_error("bad tcl result");
   }
 }
-