#include <tcl.h>
#include <strings.h>

/** ClientData implementation for mapping funcs to procs. */
struct fpinfo {
  char *funcname;
  int numargs;
  char *procname;
  Tcl_ValueType type;
};

/** Mathfunc handler.  Uses a proc for the hard work. */
static int
funcproc_handler(clientData, interp, args, resultPtr)
     ClientData clientData;
     Tcl_Interp *interp;
     Tcl_Value *args;
     Tcl_Value *resultPtr;
{
  struct fpinfo *info = (struct fpinfo *)clientData;
  Tcl_DString cmd;
  int i;

  Tcl_DStringInit(&cmd);
  Tcl_DStringAppend(&cmd, info->procname, -1);
  for (i=0 ; i<info->numargs ; i++) {
    char buf[128]; /* Arbitrary large amount! */
    switch (args[i].type) {
    case TCL_INT:
      sprintf(buf, "%ld", args[i].intValue);
      break;
    case TCL_DOUBLE:
      sprintf(buf, "%.17g", args[i].doubleValue);
      break;
    default:
      Tcl_AppendResult(interp, "unknown type of argument to ",
		       info->funcname, NULL);
      return TCL_ERROR;
    }
    Tcl_DStringAppendElement(&cmd, buf);
  }

  if (Tcl_Eval(interp, Tcl_DStringValue(&cmd)) != TCL_OK) {
    Tcl_DStringFree(&cmd);
    Tcl_AddErrorInfo(interp, "\n    (while evaluating function ");
    Tcl_AddErrorInfo(interp, info->funcname);
    Tcl_AddErrorInfo(interp, ")");
    return TCL_ERROR;
  }
  Tcl_DStringFree(&cmd);
  Tcl_DStringGetResult(interp, &cmd);

  switch (info->type) {
  case TCL_INT:
    /* Urlge!  Need a temporary... */
    if (Tcl_GetInt(interp, Tcl_DStringValue(&cmd), &i) != TCL_OK) {
      Tcl_AddErrorInfo(interp, "\n    (while returning from function ");
      Tcl_AddErrorInfo(interp, info->funcname);
      Tcl_AddErrorInfo(interp, ")");
      Tcl_DStringFree(&cmd);
      return TCL_ERROR;
    }
    Tcl_DStringFree(&cmd);
    resultPtr->intValue = i;
    resultPtr->type = TCL_INT;
    Tcl_ResetResult(interp);
    return TCL_OK;
  case TCL_DOUBLE:
    if (Tcl_GetDouble(interp, Tcl_DStringValue(&cmd),
		      &resultPtr->doubleValue) != TCL_OK) {
      Tcl_AddErrorInfo(interp, "\n    (while returning from function ");
      Tcl_AddErrorInfo(interp, info->funcname);
      Tcl_AddErrorInfo(interp, ")");
      Tcl_DStringFree(&cmd);
      return TCL_ERROR;
    }
    Tcl_DStringFree(&cmd);
    resultPtr->type = TCL_DOUBLE;
    Tcl_ResetResult(interp);
    return TCL_OK;
  default:
    /* I don't expect to reach this... */
    Tcl_AppendResult(interp, "BAD RETURN TYPE", NULL);
    Tcl_DStringFree(&cmd);
    return TCL_ERROR;
  }
}

/**
 * Install a new mathfunc handler. The clientdata argument specifies
 * what the return type is going to be.
 * @see		Tcl_CreateMathFunc()
 */
static int
func_cmd(clientdata, interp, argc, argv)
     ClientData clientdata; /* This is going to be the type of command */
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
  struct fpinfo *info;
  Tcl_ValueType *tvec;
  int numargs, i;

  if (argc != 4) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		     " funcname numparams procname\"", NULL);
    return TCL_ERROR;
  } else if (Tcl_GetInt(interp, argv[2], &numargs) != TCL_OK) {
    return TCL_ERROR;
  } else if (numargs<0) {
    Tcl_AppendResult(interp, "number of function parameters must not ",
                     "be negative", NULL);
    return TCL_ERROR;
  }

  info = (struct fpinfo *)ckalloc(sizeof(struct fpinfo));
  info->funcname = strcpy((char *)ckalloc(strlen(argv[1])+1), argv[1]);
  info->numargs = numargs;
  info->procname = strcpy((char *)ckalloc(strlen(argv[3])+1), argv[3]);
  info->type = (Tcl_ValueType)clientdata;

  /* Could use alloca() for the next line... */
  /* Note the +1 so that a zero-sized alloc never happens... */
  tvec = (Tcl_ValueType*)ckalloc(sizeof(Tcl_ValueType)*(numargs+1));
  for (i=0 ; i<numargs ; i++) {
    tvec[i] = TCL_EITHER;
  }

  /* The man page is unclear as to whether tvec can be deallocated. */
  Tcl_CreateMathFunc(interp, argv[1], numargs, tvec, funcproc_handler,
		     (ClientData)info); /* no way to uninstall... <sigh> */

  /* Not needed if was alloca()ed... */
  ckfree((void*)tvec);
  return TCL_OK;
}

/** Standard installation routine. */
int
Funcproc_Init(interp)
     Tcl_Interp *interp;
{
  Tcl_CreateCommand(interp, "intfunc",    func_cmd,
		    (ClientData)TCL_INT, NULL);
  Tcl_CreateCommand(interp, "doublefunc", func_cmd,
		    (ClientData)TCL_DOUBLE, NULL);
  return TCL_OK;
}