summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/support/cltkEval.c
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/support/cltkEval.c')
-rw-r--r--otherlibs/labltk/support/cltkEval.c212
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");
}
}
-
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-19 17:03:26 +0000