#include "escheme.h"
#include "mathlink.h"

#define scheme_make_bool(i) (i ? scheme_true : scheme_false)

#define linkpoint(n) ((mathlink*)argv[n])->val

typedef struct
{
	Scheme_Type type;
	MLINK val;
}mathlink;

Scheme_Type MathLink_Type;

static Scheme_Object *warning(int argc, Scheme_Object **argv)
{
	scheme_warning("%T", argv[0]);
	return scheme_void;
}

static Scheme_Object *init_and_openlink(int argc, Scheme_Object **argv)
{
	long err;
	MLENV ep;
	MLINK lp;
	mathlink *ret;
	char **arg;
	int i;
	
	arg = calloc( argc+1, sizeof(char*));
	arg[0] = "ml";
	for(i=0;i<argc;i++)
		arg[i+1] = SCHEME_BYTE_STR_VAL( argv[i]);
	
#if MACINTOSH_MATHLINK
	MLYieldFunctionObject yielder;
	argc = mlmactty_init( &argv);
#endif
	
	ep =  MLInitialize( (MLParametersPointer)0);
	if( ep == (MLENV)0)
	{
		MLDeinitialize( ep);
		scheme_signal_error("MathLink Initialize Error");
	}

#if MACINTOSH_MATHLINK
	yielder = MLCreateYieldFunction( ep, NewMLYielderProc( MLDefaultYielder), 0);
#endif

	lp = MLOpenArgv( ep, arg, arg+(argc+1), &err);
	if( lp == (MLINK)0)
	{
		MLClose( lp);
		scheme_signal_error("MathLink Open Error");
	}

#if MACINTOSH_MATHLINK
	MLSetYieldFunction( lp, yielder);
#endif
	
	ret = scheme_malloc_atomic( sizeof( mathlink));
	ret->type = MathLink_Type;
	ret->val = lp;
	return ((Scheme_Object*)ret);
}

static Scheme_Object *MathPutFunction(int argc, Scheme_Object **argv)
{
	return scheme_make_bool( MLPutFunction( linkpoint(2), SCHEME_SYM_VAL( argv[0]), SCHEME_INT_VAL( argv[1])));
}

static Scheme_Object *MathPutArgCount(int argc, Scheme_Object **argv)
{
	return scheme_make_bool( MLPutArgCount( linkpoint(1), SCHEME_INT_VAL( argv[0])));
}

static Scheme_Object *MathPutString(int argc, Scheme_Object **argv)
{
	unsigned short *s;
	long ulen;

	s = scheme_ucs4_to_utf16( SCHEME_CHAR_STR_VAL( argv[0]), 0, SCHEME_CHAR_STRLEN_VAL( argv[0]), s, -1, &ulen, 0);
	
	return scheme_make_bool( MLPutUnicodeString( linkpoint(1), s, ulen));
}

static Scheme_Object *MathPutNext(int argc, Scheme_Object **argv)
{
	return scheme_make_bool( MLPutNext( linkpoint(1), SCHEME_INT_VAL( argv[0])));
}

static Scheme_Object *MathNextPacket(int argc, Scheme_Object **argv)
{
	return scheme_make_integer( MLNextPacket( linkpoint(0)));
}

static Scheme_Object *MathEndPacket(int argc, Scheme_Object **argv)
{ 
	return scheme_make_bool( MLEndPacket( linkpoint(0)));
}

static Scheme_Object *MathNewPacket(int argc, Scheme_Object **argv)
{
	return scheme_make_bool( MLNewPacket( linkpoint(0)));
}

static Scheme_Object *MathGetString(int argc, Scheme_Object **argv)
{
	unsigned short *s1;
	mzchar *s2;
	long n, ulen;
	
	MLGetUnicodeString( linkpoint(0), &s1, &n);
	s2 = scheme_utf16_to_ucs4(s1, 0, n, s2, -1, &ulen, 1);
	MLDisownUnicodeString( linkpoint(0), s1, n);
	s2[ulen] = 0;
	return scheme_make_sized_char_string( s2, ulen, 0);
}

static Scheme_Object *MathGetNext(int argc, Scheme_Object **argv)
{
	return scheme_make_integer( MLGetNext( linkpoint(0)));
}

static Scheme_Object *MathGetArgCount(int argc, Scheme_Object **argv)
{
	long len;
	
	MLGetArgCount( linkpoint(0), &len);
	return scheme_make_integer( len);
}

static Scheme_Object *MathClose(int argc, Scheme_Object **argv)
{
	MLClose( linkpoint(0));
	return scheme_void;
}

static Scheme_Object *SCHEME_MathLinkP(int argc, Scheme_Object **argv)
{
	return scheme_make_bool( SCHEME_TYPE( argv[0]) == MathLink_Type);
}


Scheme_Object *scheme_reload(Scheme_Env *env)
{
  Scheme_Env *menv;
  Scheme_Object *proc;

  menv = scheme_primitive_module(scheme_intern_symbol("ml"), env);


  proc = scheme_make_prim_w_arity(warning, "warning", 1, 1);
  scheme_add_global("warning", proc, menv);

  proc = scheme_make_prim_w_arity(init_and_openlink, "init_and_openlink", 0, -1);
  scheme_add_global("init_and_openlink", proc, menv);

  proc = scheme_make_prim_w_arity(MathPutFunction, "MathPutFunction", 3, 3);
  scheme_add_global("MathPutFunction", proc, menv);

  proc = scheme_make_prim_w_arity(MathPutArgCount, "MathPutArgCount", 2, 2);
  scheme_add_global("MathPutArgCount", proc, menv);

  proc = scheme_make_prim_w_arity(MathPutString, "MathPutString", 2, 2);
  scheme_add_global("MathPutString", proc, menv);

  proc = scheme_make_prim_w_arity(MathPutNext, "MathPutNext", 2, 2);
  scheme_add_global("MathPutNext", proc, menv);

  proc = scheme_make_prim_w_arity(MathNextPacket, "MathNextPacket", 1, 1);
  scheme_add_global("MathNextPacket", proc, menv);

  proc = scheme_make_prim_w_arity(MathEndPacket, "MathEndPacket", 1, 1);
  scheme_add_global("MathEndPacket", proc, menv);

  proc = scheme_make_prim_w_arity(MathNewPacket, "MathNewPacket", 1, 1);
  scheme_add_global("MathNewPacket", proc, menv);

  proc = scheme_make_prim_w_arity(MathGetString, "MathGetString", 1, 1);
  scheme_add_global("MathGetString", proc, menv);

  proc = scheme_make_prim_w_arity(MathGetNext, "MathGetNext", 1, 1);
  scheme_add_global("MathGetNext", proc, menv);

  proc = scheme_make_prim_w_arity(MathGetArgCount, "MathGetArgCount", 1, 1);
  scheme_add_global("MathGetArgCount", proc, menv);

  proc = scheme_make_prim_w_arity(MathClose, "MathClose", 1, 1);
  scheme_add_global("MathClose", proc, menv);

  proc = scheme_make_prim_w_arity(SCHEME_MathLinkP, "MathLink?", 1, 1);
  scheme_add_global("MathLink?", proc, menv);

  scheme_finish_primitive_module(menv);
  
  return scheme_void;
}

Scheme_Object *scheme_initialize(Scheme_Env *env)
{
  MathLink_Type = scheme_make_type( "<MathLink>");
  return scheme_reload(env);
}

Scheme_Object *scheme_module_name()
{
  return scheme_intern_symbol("ml");
}