#include "guile.h"

#ifdef HAVE_GTCLTK


#ifndef alloca
#ifdef __GNUC__
#define alloca __builtin_alloca
#else /* __GNUC__ not defined.  */
#if HAVE_ALLOCA_H
#include <alloca.h>
#else /* not HAVE_ALLOCA_H */
#if defined (MSDOS) && !defined (__TURBOC__)
#include <malloc.h>
#else /* not MSDOS, or __TURBOC__ */
#if defined(_AIX)
#include <malloc.h>
 #pragma alloca
#endif /* not _AIX */
#endif /* not MSDOS, or __TURBOC__ */
#endif /* not HAVE_ALLOCA_H */
#endif /* __GNUC__ not defined.  */
#endif /* alloca not defined.  */

#include "../gtcl/tclInt.h"


#include "gtcl.h"

static sizet
free_interp (obj)
     SCM obj;
{
  SCMDATA (obj) = EOL;
  Tcl_DeleteInterp (TERP (obj));
  return 0;
}

static SCM
mark_interp (obj)
     SCM obj;
{
  if (GC8MARKP (obj))
    return BOOL_F;

  SETGC8MARK (obj);
  return SCMDATA (obj); 
}

static int
print_interp (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_lputs("#<tcl-interpreter ", port);
  scm_intprint(exp, 16, port);
  scm_lputc('>', port);
  return 1;
}

static scm_smobfuns tcl_interp_smob 
= {mark_interp, free_interp, print_interp, 0};
int scm_tc16_tcl_interp;



static char s_tcl_create_interp[] = "tcl-create-interp";

static SCM
tcl_create_interp ()
{
  SCM answer;
  SCM cell2;
  NEWCELL (answer);
  NEWCELL (cell2);
  DEFER_INTS;
  CDR (answer) = (SCM)Tcl_CreateInterp ();
  CAR (answer) = scm_tc16_tcl_interp;
  SCMDATA (answer) = cell2;
  PROPS (answer) = EOL;
  SELF (answer) = answer;
  ALLOW_INTS;
  return answer;
}


static char s_tcl_global_eval[] = "tcl-global-eval";

static SCM
tcl_global_eval (tobj, script)
     SCM tobj;
     SCM script;
{
  char * bufp;
  int status;

  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_global_eval);
  ASSERT (NIMP (script) && STRINGP (script), script, ARG2, s_tcl_global_eval);
  
  bufp = alloca (1 + LENGTH (script));
  bcopy (CHARS (script), bufp, LENGTH (script));
  bufp[LENGTH(script)] = 0;
  DEFER_INTS;
  status = Tcl_GlobalEval (TERP (tobj), bufp);
  ALLOW_INTS;
  /* !!! fixme -- leaking "result" */
  return scm_cons (MAKINUM (status), makfrom0str (TERP (tobj)->result));
}



static SCM
listify_strings (argc, argv)
     int argc;
     char * argv[];
{
  SCM answer;

  answer = EOL;
  while (argc--)
    {
      answer = scm_cons (makfrom0str (argv[argc]), answer);
    }
  return answer;
  
}

static SCM id_fn;
static char s_id_fn[] = " id-fn";

static SCM
scm_id_fn (obj)
     SCM obj;
{
  return obj;
}

static char s_tcl_create_command[] = "tcl-create-command";

static int
invoke_tcl_command (data, interp, argc, argv)
     ClientData data;
     Tcl_Interp * interp;
     int argc;
     char * argv[];
{
  SCM tobj;
  SCM proc;
  SCM result;
  tobj = CAR((SCM)interp->client_data);
  proc = CAR ((SCM)data);
#if 1
  result = scm_app_wdr (proc, listify_strings (argc - 1, argv + 1), EOL, id_fn);
#else
  result = scm_apply (proc, listify_strings (argc - 1, argv + 1), EOL);
#endif

  if (NIMP (result) && (STRINGP (result) || SYMBOLP (result)))
    {
      Tcl_SetResult (interp, CHARS (result), TCL_VOLATILE);
      return TCL_OK;
    }
  else if (NUMBERP (result))
    {
      SCM name;
      name = scm_number2string (result, MAKINUM (10));
      Tcl_SetResult (interp, CHARS (CDR (name)), TCL_VOLATILE);
      return TCL_OK;
    }
  else if (NIMP (result) && CONSP (result) && INUMP (CAR (result)) &&
	   NIMP (CDR (result)) &&
	   (STRINGP (CDR (result)) || SYMBOLP (result)))
    {
      Tcl_SetResult (interp, CHARS (CDR (result)), TCL_VOLATILE);
      return INUM (result);
    }
  else
    {
      Tcl_SetResult (interp, "Strange Scheme result", TCL_STATIC);
      return TCL_ERROR;
    }
}

static void
delete_tcl_command (data)
     ClientData data;
{
  SCM obj;
  if (CONSP (data))
    {
      obj = (SCM) data;
      if (SCMDATA (CDR (obj)) != EOL)
	PROPS (CDR (obj)) = scm_delq (obj, PROPS (CDR (obj)));
    }
}

static SCM
tcl_create_command (tobj, name, proc)
     SCM tobj;
     SCM name;
     SCM proc;
{
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_create_command);
  ASSERT (NIMP (name) && (STRINGP (name) || SYMBOLP (name)), name, ARG2, s_tcl_create_command);
  ASSERT (scm_procedurep (proc) == BOOL_T, proc, ARG3, s_tcl_create_command);
  PROPS (tobj) = scm_acons (proc, tobj, PROPS (tobj));
  DEFER_INTS;
  Tcl_CreateCommand (TERP (tobj), CHARS (name),
		     invoke_tcl_command,
		     (ClientData)CAR (PROPS (tobj)),
		     delete_tcl_command);
  ALLOW_INTS;
  return UNSPECIFIED;
}


static char s_tcl_delete_command[] = "tcl-delete-command";

static SCM
tcl_delete_command (tobj, name)
     SCM tobj;
     SCM name;
{
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_delete_command);
  ASSERT (NIMP (name) && (STRINGP(name) || SYMBOLP (name)), name, ARG2, s_tcl_delete_command);
  Tcl_DeleteCommand (TERP (tobj), CHARS (name));
  return UNSPECIFIED;
}



static char s_tcl_get_int[] = "tcl-get-int";
static char s_tcl_get_double[] = "tcl-get-double";
static char s_tcl_get_boolean[] = "tcl-get-boolean";

static SCM
tcl_get_int (tobj, name)
     SCM tobj;
     SCM name;
{
  int c_answer;
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_get_int);
  ASSERT (NIMP (name)
	  && (SYMBOLP (name) || STRINGP (name)),
	  name, ARG2, s_tcl_get_int);
  ASSERT (TCL_OK == Tcl_GetInt (TERP (tobj), CHARS (name), &c_answer),
	  name, TERP (tobj)->result, s_tcl_get_int);

  /* !!! leaking result */
  return scm_long2num ((long)c_answer);
}

static SCM
tcl_get_double (tobj, name)
     SCM tobj;
     SCM name;
{
  double c_answer;
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_get_double);
  ASSERT (NIMP (name)
	  && (SYMBOLP (name) || STRINGP (name)),
	  name, ARG2, s_tcl_get_double);
  ASSERT (TCL_OK == Tcl_GetDouble (TERP (tobj), CHARS (name), &c_answer),
	 tobj, TERP (tobj)->result, s_tcl_get_double);
  /* !!! leaking result */
  return scm_makdbl (c_answer, 0.0);
}

static SCM
tcl_get_boolean (tobj, name)
     SCM tobj;
     SCM name;
{
  int c_answer;
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_get_boolean);
  ASSERT (NIMP (name)
	  && (SYMBOLP (name) || STRINGP (name)),
	  name, ARG2, s_tcl_get_boolean);
  ASSERT (TCL_OK == Tcl_GetBoolean (TERP (tobj), CHARS (name), &c_answer),
	  tobj, TERP (tobj)->result, s_tcl_get_boolean);
  /* !!! leaking result */
  return (c_answer
	  ? BOOL_T
	  : BOOL_F);
}


static char s_tcl_split_list[] = "tcl-split-list";
static SCM
tcl_split_list (tobj, name)
     SCM tobj;
     SCM name;
{
  char **argv;
  int argc;
  int tcl_result;

  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_split_list);
  ASSERT (NIMP (name)
	  && (SYMBOLP (name) || STRINGP (name)),
	  name, ARG2, s_tcl_split_list);
  DEFER_INTS;
  tcl_result = (TCL_OK == Tcl_SplitList (TERP (tobj),
					 CHARS (name), &argc, &argv));
  ALLOW_INTS;
  ASSERT (tcl_result, name, TERP (tobj)->result, s_tcl_split_list);
  /* !!! leaking result */
  {
    SCM answer;
    answer = listify_strings (argc, argv);
    DEFER_INTS;
    free (argv);
    ALLOW_INTS;
    return answer;
  }
}

static char s_tcl_merge[] = "tcl-merge";
static SCM
tcl_merge (tobj, args)
     SCM tobj;
     SCM args;
{
  int argc;
  char ** argv;
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_merge);
  argc = scm_ilength (args);
  if (argc == 0)
    argv = 0;
  else
    {
      int i;
      DEFER_INTS;
      argv = (char **)alloca (sizeof (char *) * argc);
      ALLOW_INTS;
      for (i = 0; i < argc; ++i)
	{
	  ASSERT (NIMP (CAR (args))
		  && (STRINGP (CAR (args)) || SYMBOLP (CAR (args))),
		  CAR (args), "all arguments must be strings",
		  s_tcl_merge);
	  argv[i] = CHARS (CAR (args));
	  args = CDR (args);
	}
    }
  /* !!! leaking result */
  {
    char * c_answer;
    SCM answer;
    DEFER_INTS;
    c_answer = Tcl_Merge (argc, argv);
    ALLOW_INTS;
    answer = makfrom0str (c_answer);
    DEFER_INTS;
    free (c_answer);
    ALLOW_INTS;
    return answer;
  }
}


static char s_tcl_trace_var2[] = "tcl-trace-var2";
static char s_tcl_untrace_var2[] = "tcl-untrace-var2";

static char *
trace_variable (data, interp, name, name2, flags)
     ClientData data;
     Tcl_Interp * interp;
     char * name;
     char * name2;
     int flags;
{
  SCM proc;
  SCM result;
  proc = (SCM)CAR (data);
  result = scm_app_wdr (proc,
			scm_listify (SELF_interp (interp),
				     makfrom0str (name),
				     makfrom0str_opt (name2),
				     MAKINUM (flags),
				     SCM_UNDEFINED),
			EOL,
			id_fn);
  return ((result == BOOL_F)
	  ? "Error from Scheme variable trace."
	  : 0);
}

static SCM
tcl_trace_var2 (tobj, name, index, flags, thunk)
     SCM tobj;
     SCM name;
     SCM index;
     SCM flags;
     SCM thunk;
{
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_trace_var2);
  ASSERT (NIMP (name)
	  && (SYMBOLP (name) || STRINGP (name)),
	  name, ARG2, s_tcl_trace_var2);
  ASSERT ((BOOL_F == index)
	  || (NIMP (index)
	      && (SYMBOLP (index) || STRINGP (index))),
	  name, ARG3, s_tcl_trace_var2);
  ASSERT (INUMP (flags), flags, ARG4, s_tcl_trace_var2);
  ASSERT (scm_procedurep (thunk), thunk, ARG5, s_tcl_trace_var2);
  PROPS (tobj) = scm_acons (thunk, EOL, PROPS (tobj));
  DEFER_INTS;
  Tcl_TraceVar2 (TERP (tobj),
		 CHARS (name),
		 ((index == BOOL_F)
		  ? 0
		  : CHARS (index)),
		 INUM (flags),
		 trace_variable,
		 (ClientData)CAR (PROPS (tobj)));
  /* !!! leaking result */
  ALLOW_INTS;
  return UNSPECIFIED;
}



static SCM
tcl_untrace_var2 (tobj, name, index, flags, thunk)
     SCM tobj;
     SCM name;
     SCM index;
     SCM flags;
     SCM thunk;
{
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_untrace_var2);
  ASSERT (NIMP (name)
	  && (SYMBOLP (name) || STRINGP (name)),
	  name, ARG2, s_tcl_untrace_var2);
  ASSERT ((NIMP (name) && (SYMBOLP (name) || STRINGP (name))),
	  name, ARG2, s_tcl_untrace_var2);
  ASSERT ((BOOL_F == index)
	  || (NIMP (index)
	      && (SYMBOLP (index) || STRINGP (index))),
	  name, ARG3, s_tcl_untrace_var2);
  ASSERT (INUMP (flags), flags, ARG4, s_tcl_untrace_var2);
  ASSERT (scm_procedurep (thunk), thunk, ARG5, s_tcl_untrace_var2);

  {
    SCM pos;
    pos = PROPS (tobj);
    while (pos != BOOL_F)
      {
	if (CAR (CAR (pos)) == thunk)
	  {
	    int got_it;
	    DEFER_INTS;
	    got_it = Tcl_UntraceVar2 (TERP (tobj),
				      CHARS (name),
				      ((BOOL_F == index)
				       ? 0
				       : CHARS (index)),
				      flags,
				      trace_variable,
				      (ClientData)CAR (pos));
	    ALLOW_INTS;
	    if (got_it)
	      {
		PROPS (tobj) = scm_delq (CAR (pos), PROPS (tobj));
		return BOOL_T;
	      }
	  }
	pos = CDR (pos);
      }
    return BOOL_F;
  }
}



static char s_tcl_set_var2[] = "tcl-set-var2";

SCM
tcl_set_var2 (tobj, name, index, value, flags)
     SCM tobj;
     SCM name;
     SCM index;
     SCM value;
     SCM flags;
{
  char * c_answer;
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_set_var2);
  ASSERT (NIMP (name)
	  && (SYMBOLP (name) || STRINGP (name)),
	  name, ARG2, s_tcl_set_var2);
  ASSERT ((NIMP (name) && (SYMBOLP (name) || STRINGP (name))),
	  name, ARG2, s_tcl_set_var2);
  ASSERT ((BOOL_F == index)
	  || (NIMP (index)
	      && (SYMBOLP (index) || STRINGP (index))),
	  name, ARG3, s_tcl_set_var2);
  ASSERT (NIMP (value) && (STRINGP (value) || SYMBOLP (value)),
	  value, ARG4, s_tcl_set_var2);
  ASSERT (INUMP (flags), flags, ARG5, s_tcl_set_var2);

  DEFER_INTS;
  c_answer = Tcl_SetVar2 (TERP (tobj),
			  CHARS (name),
			  ((index == BOOL_F) ? 0 : CHARS (index)),
			  CHARS (value),
			  INUM (flags));
  ALLOW_INTS;
  /* !!! leaking c_answer */
  return makfrom0str_opt (c_answer);
}


static char s_tcl_get_var2[] = "tcl-get-var2";

SCM
tcl_get_var2 (tobj, name, index, flags)
     SCM tobj;
     SCM name;
     SCM index;
     SCM flags;
{
  char * c_answer;
  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_get_var2);
  ASSERT (NIMP (name)
	  && (SYMBOLP (name) || STRINGP (name)),
	  name, ARG2, s_tcl_get_var2);
  ASSERT ((NIMP (name) && (SYMBOLP (name) || STRINGP (name))),
	  name, ARG2, s_tcl_get_var2);
  ASSERT ((BOOL_F == index)
	  || (NIMP (index)
	      && (SYMBOLP (index) || STRINGP (index))),
	  name, ARG3, s_tcl_get_var2);
  ASSERT (INUMP (flags), flags, ARG4, s_tcl_get_var2);

  DEFER_INTS;
  c_answer = Tcl_GetVar2 (TERP (tobj),
			  CHARS (name),
			  ((index == BOOL_F) ? 0 : CHARS (index)),
			  INUM (flags));
  ALLOW_INTS;
  /* !!! leaking c_answer */
  return makfrom0str_opt (c_answer);
}




static void cmd_die P((SCM));
static struct gscm_type tcl_command_type = { "tcl-command", 0, 0, cmd_die };

struct tcl_command
{
  SCM tobj;
  SCM name;
  Tcl_CmdInfo info;
};

/* when the scheme object dies: */
static void
cmd_die (obj)
     SCM obj;
{
  struct tcl_command * command;
  struct Tcl_CmdInfo * info;

  command = (struct tcl_command *)gscm_unwrap_obj (&tcl_command_type, &obj);
  info = &command->info;
  info->appDeleteProc = 0;
  info->appDeleteData = 0;
  info->appChangeProc = 0;
  Tcl_SetCommandAppInfo (TERP (command->tobj), CHARS (command->name), info);
}

/* when the tcl object dies */
static void
command_app_delete (data)
     SCM data;
{
  struct tcl_command * command;
  Tcl_CmdInfo * info;

  command = (struct tcl_command *)gscm_unwrap_obj (&tcl_command_type, &data);
  info = &command->info;
  info->proc = 0;
}

static void
command_app_change (data)
     Tcl_CmdInfo * data;
{
  struct tcl_command * command;
  Tcl_CmdInfo * info;

  command = (struct tcl_command *)gscm_unwrap_obj (&tcl_command_type,
						   data->appDeleteData);
  info = &command->info;
  info->proc = 0;
}


static char s_tcl_command [] = "tcl-command";

SCM
tcl_command (tobj, name)
     SCM tobj;
     SCM name;
{
  Tcl_CmdInfo info;
  int status;

  ASSERT (NIMP (tobj) && TERPP (tobj), tobj, ARG1, s_tcl_command);
  DEFER_INTS;
  status = Tcl_GetCommandInfo (TERP (tobj), CHARS (name), &info);
  ALLOW_INTS;

  if (!status)
    return BOOL_F;
  
  if (info.appDeleteData)
    return (SCM)info.appDeleteData;

  {
    SCM answer;
    struct tcl_command * command;
    Tcl_CmdInfo * infop;

    answer = gscm_alloc (&tcl_command_type, sizeof (struct tcl_command));
    command = (struct tcl_command *)gscm_unwrap_obj (&tcl_command_type, &answer);
    infop = &command->info;

    DEFER_INTS;
    *infop = info;
    infop->appDeleteData = (ClientData) answer;
    infop->appDeleteProc = command_app_delete;
    infop->appChangeProc = command_app_change;
    Tcl_SetCommandAppInfo (TERP (tobj), CHARS (name), infop);
    ALLOW_INTS;

    command->tobj = tobj;
    command->name = scm_makfromstr (CHARS (name), LENGTH (name), 0);
    return answer;
  }
}

SCM tcl_type_converter = BOOL_F;
SCM tcc_symbol = BOOL_F;

static char s_tcl_apply_command [] = "tcl-apply-command";
SCM
tcl_apply_command (command, args)
     SCM command;
     SCM args;
{
  struct tcl_command * cmd_data;
  Tcl_CmdInfo * info;
  int argc;
  char ** argv;
  int status;
  char static_result[TCL_RESULT_SIZE];
  SCM number_name;
  SCM answer;
  char * default_argv[2];
  
  cmd_data= (struct tcl_command *)gscm_unwrap_obj (&tcl_command_type, &command);
  info = &cmd_data->info;
  ASSERT (!!info->proc, command, "command has expired", s_tcl_apply_command);

  argc = scm_ilength (args);
  ASSERT (argc >= 0, args, ARG2, s_tcl_apply_command);
  if (argc == 0)
    argv = default_argv;
  else
    {
      int i;
      DEFER_INTS;
      argv = (char **)alloca (sizeof (char *) * (argc + 1));
      ALLOW_INTS;
      for (i = 0; i < argc; ++i)
	{
	  SCM item;

	  item = CAR (args);

	retry_item:
	  if (IMP (item))
	    {
	      if (INUMP (item))
		{
		  char * storage;
		  storage = alloca (sizeof(long) * 8);
		  sprintf (storage, "%d", INUM (item));
		  argv[i + 1] = storage;
		}
	      else if (item == BOOL_T)
		argv[i + 1] = "1";
	      else if (item == BOOL_F)
		argv[i + 1] = "0";
	      else if (scm_procedurep (item))
		{
		  static int count = 0;
		  char name[64];
		  char * calling_conventions;
		  SCM conv_string;

		item_is_proc:
		  if (!CLOSUREP (item))
		    calling_conventions = "";
		  else
		    {
		      conv_string = gscm_proc_prop (item, tcc_symbol);
		      if (!(NIMP (conv_string) && STRINGP (conv_string)))
			calling_conventions = "";
		      else
			calling_conventions = CHARS (conv_string);
		      scm_remember (&conv_string);
		    }

		  sprintf (name, "__guile#%d", count);
		  {
		    SCM tobj;
		    tobj = cmd_data->tobj;
		    PROPS (tobj) = scm_acons (item, tobj, PROPS (tobj));
		    Tcl_CreateCommand (TERP (tobj), name,
				       invoke_tcl_command,
				       (ClientData)CAR (PROPS (tobj)),
				       delete_tcl_command);
		  }

		  {
		    char * arg_string;
		    arg_string = ((char *)
				  alloca (strlen (name) + 10
					  + strlen (calling_conventions)));
		    sprintf (arg_string, "*__guile#%d%s%s",
			     count,
			     (calling_conventions[0] ? " " : ""),
			     calling_conventions);
		    argv[i + 1] = arg_string;
		  }
		  ++count;
		}
	      else if ((item == UNSPECIFIED) || (item == SCM_UNDEFINED))
		{
		signal_type_error:
		  ASSERT (0, item, "unhandled type to tcl command",
			  s_tcl_apply_command);
		}
	      else
		{
		item_is_unhandled_type:
		  if (tcl_type_converter == BOOL_F)
		    goto signal_type_error;
		  else
		    {
		      item = scm_apply (CDR (tcl_type_converter),
					scm_cons (item, EOL), EOL);
		      goto retry_item;
		    }
		}
	    }
	  else if (KEYWORDP (item))
	    argv[i + 1] = CHARS (KEYWORDSYM (item));
	  else if (STRINGP (item) || SYMBOLP (item))
	    {
	      argv[i + 1] = CHARS (CAR (args));
	    }
	  else if (NUMBERP (item))
	    {
	      number_name = scm_number2string (item, MAKINUM (10));
	      argv[i + 1] = CHARS (number_name);
	      scm_remember (&number_name);
	    }
	  else if (scm_procedurep (item))
	    {
	      goto item_is_proc;
	    }
	  else
	    {
	      goto item_is_unhandled_type;
	    }
	  args = CDR (args);
	}
    }
  argv[0] = CHARS (cmd_data->name);
  ++argc;
  DEFER_INTS;
  {
    register Interp *iptr;

    iptr = (Interp *) TERP (cmd_data->tobj);
    Tcl_FreeResult (iptr);
    iptr->result = iptr->resultSpace;
    iptr->resultSpace[0] = 0;

    status = info->proc (info->clientData, TERP (cmd_data->tobj), argc, argv);
    if (tcl_AsyncReady)
      status = Tcl_AsyncInvoke (TERP (cmd_data->tobj), status);

    answer = scm_cons (MAKINUM (status),
		       makfrom0str (TERP (cmd_data->tobj)->result));
  }
  ALLOW_INTS;
  return answer;
}





static scm_iproc subr0s[] =
{
  {s_tcl_create_interp, tcl_create_interp},
  {0, 0}
};

static scm_iproc subr2s[] =
{
  {s_tcl_global_eval, tcl_global_eval},
  {s_tcl_delete_command, tcl_delete_command},
  {s_tcl_get_int, tcl_get_int},
  {s_tcl_get_double, tcl_get_double},
  {s_tcl_get_boolean, tcl_get_boolean},
  {s_tcl_split_list, tcl_split_list},
  {s_tcl_command, tcl_command},
  {0, 0}
};

static scm_iproc lsubr2s[] =
{
  {s_tcl_apply_command, tcl_apply_command},
  {0, 0}
};

static scm_iproc subr3s[] =
{
  {s_tcl_create_command, tcl_create_command},
  {0, 0}
};


void
scm_init_tcl ()
{
  scm_tc16_tcl_interp = scm_newsmob (&tcl_interp_smob);
  scm_init_iprocs (subr0s, tc7_subr_0);
  scm_init_iprocs (subr2s, tc7_subr_2);
  scm_init_iprocs (lsubr2s, tc7_lsubr_2);
  scm_init_iprocs (subr3s, tc7_subr_3);
  scm_make_gsubr (s_tcl_merge, 1, 0, 1, tcl_merge);
  scm_make_gsubr (s_tcl_trace_var2, 5, 0, 0, tcl_trace_var2);
  scm_make_gsubr (s_tcl_untrace_var2, 5, 0, 0, tcl_untrace_var2);
  scm_make_gsubr (s_tcl_set_var2, 5, 0, 0, tcl_set_var2);
  scm_make_gsubr (s_tcl_get_var2, 4, 0, 0, tcl_get_var2);
  id_fn = scm_make_gsubr (s_id_fn, 1, 0, 0, scm_id_fn);
  tcl_type_converter = scm_sysintern ("tcl-type-converter", BOOL_F);
  tcc_symbol = scm_sysintern ("tcl-calling-convention", BOOL_F);
  CDR (tcc_symbol) = CAR (tcc_symbol);
  tcc_symbol = CAR (tcc_symbol);
}


/* classes: src_files */

/*	Copyright (C) 1995 Free Software Foundation, Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this software; see the file COPYING.  If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */

/* 
 * Parts of this code are derived from tclBasic.c.
 */



#if 0
/* 
 * tclInit.c --
 *
 *	Contains the default facilities for TCL interpreter initialization.
 */

#include "tclInt.h"
#ifndef TCL_GENERIC_ONLY
#   include "tclPort.h"
#endif

/*
 * The following structure defines all of the commands in the Tcl core,
 * and the C procedures that execute them.
 */

typedef struct {
    char *name;			/* Name of command. */
    Tcl_CmdProc *proc;		/* Procedure that executes command. */
} CmdInfo;

/*
 * Built-in commands, and the procedures associated with them:
 */

static CmdInfo builtInCmds[] = {
    /*
     * Commands in the generic core:
     */
    {NULL,		(Tcl_CmdProc *) NULL}
};


void
Tcl_CreateBuiltInCmds (iPtr)
     Interp * iPtr;
{
}

#endif /* 0 */

#endif /* HAVE_LIBTCL */

