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

#ifdef MZ_PRECISE_GC
XFORM_START_SKIP;
#endif

int MLAbort = 0;
int MLDone  = 0;
long MLSpecialCharacter = '\0';

MLINK stdlink = 0;
MLEnvironment stdenv = 0;
#if MLINTERFACE >= 3
MLYieldFunctionObject stdyielder = (MLYieldFunctionObject)0;
MLMessageHandlerObject stdhandler = (MLMessageHandlerObject)0;
#else
MLYieldFunctionObject stdyielder = 0;
MLMessageHandlerObject stdhandler = 0;
#endif /* MLINTERFACE >= 3 */

/********************************* end header *********************************/

/* To launch this program from within Mathematica use:
 *   In[1]:= link = Install["scheme.exe"]
 *
 * Or, launch this program from a shell and establish a
 * peer-to-peer connection.  When given the prompt Create Link:
 * type a port name. ( On Unix platforms, a port name is a
 * number less than 65536.  On Mac or Windows platforms,
 * it's an arbitrary word.)
 * Then, from within Mathematica use:
 *   In[1]:= link = Install["portname", LinkMode->Connect]
 */

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

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

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( stdlink, s, ulen));
}

static Scheme_Object *MathPutByteString(int argc, Scheme_Object **argv)
{
	return scheme_make_bool( MLPutByteString( stdlink, SCHEME_BYTE_STR_VAL( argv[0]), SCHEME_BYTE_STRLEN_VAL( argv[0])));
}

static Scheme_Object *MathPutReal(int argc, Scheme_Object **argv)
{
	return scheme_make_bool( MLPutReal( stdlink, SCHEME_DBL_VAL( argv[0])));
}

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

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

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

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

static Scheme_Object *MathGetByteString(int argc, Scheme_Object **argv)
{
	unsigned char *s;
	long n;
	Scheme_Object *ret;
	MLGetByteString( stdlink, &s, &n, 0L);
	ret = scheme_make_sized_byte_string(s, n, 1);
	MLDisownString( stdlink, s);
	return ret;
}

static Scheme_Object *MathGetSymbol(int argc, Scheme_Object **argv)
{
	unsigned short *s1;
	char *s2;
	long n;
	int len;
	MLGetUnicodeSymbol( stdlink, &s1, &n);
	s2 = (char *)scheme_malloc_atomic( scheme_utf8_encode(s1, 0, n, NULL, 0, 1));
	len = scheme_utf8_encode(s1, 0, n, s2, 0, 1);
	MLDisownUnicodeSymbol( stdlink, s1, n);
	return scheme_intern_exact_symbol( s2, len);
}

static Scheme_Object *MathGetCharString(int argc, Scheme_Object **argv)
{
	char *s;
	Scheme_Object *ret;
	MLGetString( stdlink, &s);
	ret = scheme_make_byte_string(s);
	MLDisownString( stdlink, s);
	return ret;
}

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

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

static Scheme_Object *MathErrorMessage(int argc, Scheme_Object **argv)
{
	return scheme_make_byte_string_without_copying( MLErrorMessage( stdlink));
}

static Scheme_Object *MathClearError(int argc, Scheme_Object **argv)
{
	return scheme_make_bool( MLClearError( stdlink));
}

static Scheme_Object *MathPutCharSymbol(int argc, Scheme_Object **argv)
{
	return scheme_make_bool( MLPutSymbol( stdlink, SCHEME_SYM_VAL( argv[0])));
}

static Scheme_Object *MathGetInteger(int argc, Scheme_Object **argv)
{
	long x;
	MLGetLongInteger( stdlink, &x);
	return scheme_make_integer( x);
}

static Scheme_Object *set_immutable(int argc, Scheme_Object **argv)
{
	SCHEME_SET_IMMUTABLE(argv[0]);
	return scheme_void;
}

static Scheme_Object *MathMain(int argc, Scheme_Object **argv)
{
	char **arg;
	int i;
	
	argc = SCHEME_VEC_SIZE(argv[0]);
	arg = calloc(argc+1, sizeof(char*));
	argv = SCHEME_VEC_ELS(argv[0]);
	arg[0] = "drlink";
	for (i=0;i<argc;i++)
		arg[i+1] = SCHEME_BYTE_STR_VAL(argv[i]);
	return scheme_make_bool( MLMain(argc+1, arg));
}

static Scheme_Object *MathAbort(int argc, Scheme_Object **argv)
{
	return ( MLAbort ? (MLAbort=0,scheme_true) : scheme_false );
}

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

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

#if  WINDOWS_MATHLINK
static int f(Scheme_Object *data)
{
	return MLReady( stdlink);
}

static Scheme_Object *MathReady(int argc, Scheme_Object **argv)
{
	MLFlush( stdlink);
	scheme_block_until( &f, NULL, NULL, 0.0);
	return scheme_void;
}
#else
static Scheme_Object *MathReady(int argc, Scheme_Object **argv)
{
	MLFlush( stdlink);
	scheme_block_until( &MLReady, NULL, stdlink, 0.0);
	return scheme_void;
}
#endif

#ifdef MZ_PRECISE_GC
XFORM_END_SKIP;
#endif

Scheme_Object *scheme_reload(Scheme_Env *env)
{
  Scheme_Env *menv;
  Scheme_Object *proc;
	
	proc = scheme_intern_symbol("link");
  menv = scheme_primitive_module(proc, env);

  proc = scheme_make_prim_w_arity(MathMain, "MathMain", 1, 1);
  scheme_add_global("MathMain", proc, menv);
	proc = scheme_make_prim_w_arity(MathPutFunction, "MathPutFunction", 2, 2);
	scheme_add_global("MathPutFunction", proc, menv);
	proc = scheme_make_prim_w_arity(MathPutString, "MathPutString", 1, 1);
	scheme_add_global("MathPutString", proc, menv);
	proc = scheme_make_prim_w_arity(MathPutReal, "MathPutReal", 1, 1);
	scheme_add_global("MathPutReal", proc, menv);
	proc = scheme_make_prim_w_arity(MathPutNext, "MathPutNext", 1, 1);
	scheme_add_global("MathPutNext", proc, menv);
	proc = scheme_make_prim_w_arity(MathNextPacket, "MathNextPacket", 0, 0);
	scheme_add_global("MathNextPacket", proc, menv);
	proc = scheme_make_prim_w_arity(MathNewPacket, "MathNewPacket", 0, 0);
	scheme_add_global("MathNewPacket", proc, menv);
	proc = scheme_make_prim_w_arity(MathGetString, "MathGetString", 0, 0);
	scheme_add_global("MathGetString", proc, menv);
	proc = scheme_make_prim_w_arity(MathGetSymbol, "MathGetSymbol", 0, 0);
	scheme_add_global("MathGetSymbol", proc, menv);
	proc = scheme_make_prim_w_arity(MathGetCharString, "MathGetCharString", 0, 0);
	scheme_add_global("MathGetCharString", proc, menv);
	proc = scheme_make_prim_w_arity(MathGetNext, "MathGetNext", 0, 0);
	scheme_add_global("MathGetNext", proc, menv);
	proc = scheme_make_prim_w_arity(MathGetArgCount, "MathGetArgCount", 0, 0);
	scheme_add_global("MathGetArgCount", proc, menv);
	proc = scheme_make_prim_w_arity(MathErrorMessage, "MathErrorMessage", 0, 0);
	scheme_add_global("MathErrorMessage", proc, menv);
	proc = scheme_make_prim_w_arity(MathClearError, "MathClearError", 0, 0);
	scheme_add_global("MathClearError", proc, menv);
	proc = scheme_make_prim_w_arity(MathGetByteString, "MathGetByteString", 0, 0);
	scheme_add_global("MathGetByteString", proc, menv);
	proc = scheme_make_prim_w_arity(MathPutByteString, "MathPutByteString", 1, 1);
	scheme_add_global("MathPutByteString", proc, menv);
	proc = scheme_make_prim_w_arity(MathPutCharSymbol, "MathPutCharSymbol", 1, 1);
	scheme_add_global("MathPutCharSymbol", proc, menv);
	proc = scheme_make_prim_w_arity(MathGetInteger, "MathGetInteger", 0, 0);
	scheme_add_global("MathGetInteger", proc, menv);
	proc = scheme_make_prim_w_arity(set_immutable, "set-immutable!", 1, 1);
	scheme_add_global("set-immutable!", proc, menv);
	proc = scheme_make_prim_w_arity(MathAbort, "MathAbort", 0, 0);
	scheme_add_global("MathAbort", proc, menv);
	proc = scheme_make_prim_w_arity(MathClose, "MathClose", 0, 0);
	scheme_add_global("MathEndPacket", proc, menv);
	proc = scheme_make_prim_w_arity(MathClose, "MathClose", 0, 0);
	scheme_add_global("MathClose", proc, menv);
	proc = scheme_make_prim_w_arity(MathReady, "MathReady", 0, 0);
	scheme_add_global("MathReady", proc, menv);

  scheme_finish_primitive_module(menv);
  
  return scheme_void;
}

#ifdef MZ_PRECISE_GC
XFORM_START_SKIP;
#endif

Scheme_Object *scheme_initialize(Scheme_Env *env)
{
  return scheme_reload(env);
}

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

static char* evalstrs[] = {
	"BeginPackage[ \"SchemeLink`\"]",
	(char*)0,
	"Scheme[{}] = {}",
	(char*)0,
	"Scheme[exp_List] := First[exp] @@ Scheme /@ Rest[exp]",
	(char*)0,
	"Scheme[exp_] = exp",
	(char*)0,
	"Scheme::usage = \"Scheme[S-exp] evaluates S-exp in Mathematica.\"",
	(char*)0,
	"Eval::usage = \"Eval[S-exp] evaluates S-exp in PLT Scheme.\"",
	(char*)0,
	"Eval::inputtype = \"SchemeEval only allows S-exp (or M-exp) as in",
	"put: `1`\"",
	(char*)0,
	"Eval::mlink = \"MathLink error: `1`.\"",
	(char*)0,
	"Eval::multiplereturn = \"Scheme return multiple values.\"",
	(char*)0,
	"EndPackage[ ]",
	(char*)0,
	(char*)0
};
#define CARDOF_EVALSTRS 10

static int _definepattern P(( MLINK, char*, char*, int));

static int _doevalstr P(( MLINK, int));


#if MLPROTOTYPES
int MLInstall( MLINK mlp)
#else
int MLInstall(mlp) MLINK mlp;
#endif
{
	int _res;
	_res = MLConnect(mlp);
	if (_res) _res = _doevalstr( mlp, 0);
	if (_res) _res = _doevalstr( mlp, 1);
	if (_res) _res = _doevalstr( mlp, 2);
	if (_res) _res = _doevalstr( mlp, 3);
	if (_res) _res = _doevalstr( mlp, 4);
	if (_res) _res = _definepattern(mlp, "Eval[exp_]", "exp", 0);
	if (_res) _res = _doevalstr( mlp, 5);
	if (_res) _res = _doevalstr( mlp, 6);
	if (_res) _res = _doevalstr( mlp, 7);
	if (_res) _res = _doevalstr( mlp, 8);
	if (_res) _res = _doevalstr( mlp, 9);
	if (_res) _res = MLPutSymbol( mlp, "End");
	if (_res) _res = MLFlush( mlp);
	return _res;
} /* MLInstall */


/******************************* begin trailer ********************************/

#ifndef EVALSTRS_AS_BYTESTRINGS
#	define EVALSTRS_AS_BYTESTRINGS 1
#endif

#if CARDOF_EVALSTRS
static int  _doevalstr( MLINK mlp, int n)
{
	long bytesleft, charsleft, bytesnow;
#if !EVALSTRS_AS_BYTESTRINGS
	long charsnow;
#endif
	char **s, **p;
	char *t;

	s = evalstrs;
	while( n-- > 0){
		if( *s == 0) break;
		while( *s++ != 0){}
	}
	if( *s == 0) return 0;
	bytesleft = 0;
	charsleft = 0;
	p = s;
	while( *p){
		t = *p; while( *t) ++t;
		bytesnow = t - *p;
		bytesleft += bytesnow;
		charsleft += bytesnow;
#if !EVALSTRS_AS_BYTESTRINGS
		t = *p;
		charsleft -= MLCharacterOffset( &t, t + bytesnow, bytesnow);
		/* assert( t == *p + bytesnow); */
#endif
		++p;
	}


	MLPutNext( mlp, MLTKSTR);
#if EVALSTRS_AS_BYTESTRINGS
	p = s;
	while( *p){
		t = *p; while( *t) ++t;
		bytesnow = t - *p;
		bytesleft -= bytesnow;
		MLPut8BitCharacters( mlp, bytesleft, (unsigned char*)*p, bytesnow);
		++p;
	}
#else
	MLPut7BitCount( mlp, charsleft, bytesleft);
	p = s;
	while( *p){
		t = *p; while( *t) ++t;
		bytesnow = t - *p;
		bytesleft -= bytesnow;
		t = *p;
		charsnow = bytesnow - MLCharacterOffset( &t, t + bytesnow, bytesnow);
		/* assert( t == *p + bytesnow); */
		charsleft -= charsnow;
		MLPut7BitCharacters(  mlp, charsleft, *p, bytesnow, charsnow);
		++p;
	}
#endif
	return MLError( mlp) == MLEOK;
}
#endif /* CARDOF_EVALSTRS */


static int  _definepattern( MLINK mlp, char *patt, char *args, int func_n)
{
	MLPutFunction( mlp, "DefineExternal", (long)3);
	  MLPutString( mlp, patt);
	  MLPutString( mlp, args);
	  MLPutInteger( mlp, func_n);
	return !MLError(mlp);
} /* _definepattern */


#if WINDOWS_MATHLINK
#if MLINTERFACE >= 3
MLMDEFN( void, MLDefaultHandler, ( MLINK mlp, int message, int n))
#else
MLMDEFN( void, MLDefaultHandler, ( MLINK mlp, unsigned long message, unsigned long n))
#endif /* MLINTERFACE >= 3 */
#else
#if MLINTERFACE >= 3
#if MLPROTOTYPES
void MLDefaultHandler( MLINK mlp, int message, int n)
#else
void MLDefaultHandler( mlp, message, n)
	MLINK mlp;
	int message, n;
#endif
#else
#if MLPROTOTYPES
void MLDefaultHandler( MLINK mlp, unsigned long message, unsigned long n)
#else
void MLDefaultHandler( mlp, message, n)
	MLINK mlp;
	unsigned long message, n;
#endif
#endif /* MLINTERFACE >= 3 */
#endif
{
	switch (message){
	case MLTerminateMessage:
		MLDone = 1;
	case MLInterruptMessage:
	case MLAbortMessage:
		MLAbort = 1;
	default:
		return;
	}
}

#if MLINTERFACE >= 3
static int _MLMain( char **argv, char **argv_end, char *commandline)
#else
static int _MLMain( charpp_ct argv, charpp_ct argv_end, charp_ct commandline)
#endif /* MLINTERFACE >= 3 */
{
	MLINK mlp;
#if MLINTERFACE >= 3
	int err;
#else
	long err;
#endif /* MLINTERFACE >= 3 */

	if( !stdenv)
		stdenv = MLInitialize( (MLParametersPointer)0);
	if( stdenv == (MLEnvironment)0) goto R0;

#if MLINTERFACE >= 3
	if( !stdhandler)
		stdhandler = (MLMessageHandlerObject)MLDefaultHandler;
#else
	if( !stdhandler)
		stdhandler = MLCreateMessageHandler( stdenv, MLDefaultHandler, 0);
#endif /* MLINTERFACE >= 3 */



	mlp = commandline
		? MLOpenString( stdenv, commandline, &err)
		: MLOpenArgcArgv( stdenv, (int)(argv_end - argv), argv, &err);
	if( mlp == (MLINK)0){
		MLAlert( stdenv, MLErrorString( stdenv, err));
		goto R1;
	}

	if( stdyielder) MLSetYieldFunction( mlp, stdyielder);
	if( stdhandler) MLSetMessageHandler( mlp, stdhandler);

	MLInstall( mlp);
	stdlink = mlp;
	return 1;

R1:	MLDeinitialize( stdenv);
	stdenv = (MLEnvironment)0;
R0:	return 0;
} /* _MLMain */


#if MLINTERFACE >= 3
int MLMain( int argc, char **argv)
#else
int MLMain( int argc, charpp_ct argv)
#endif /* MLINTERFACE >= 3 */
{
#if MLINTERFACE >= 3
 	return _MLMain( argv, argv + argc, (char *)0);
#else
 	return _MLMain( argv, argv + argc, (charp_ct)0);
#endif /* MLINTERFACE >= 3 */
}

#ifdef MZ_PRECISE_GC
XFORM_END_SKIP;
#endif