=================================================================== RCS file: /home/cvs/OpenXM/src/ox_math/mlo.c,v retrieving revision 1.11 retrieving revision 1.18 diff -u -p -r1.11 -r1.18 --- OpenXM/src/ox_math/mlo.c 2003/01/13 12:04:53 1.11 +++ OpenXM/src/ox_math/mlo.c 2003/03/23 21:56:11 1.18 @@ -1,5 +1,5 @@ /* -*- mode: C -*- */ -/* $OpenXM: OpenXM/src/ox_math/mlo.c,v 1.10 2003/01/11 12:38:57 ohara Exp $ */ +/* $OpenXM: OpenXM/src/ox_math/mlo.c,v 1.17 2003/03/18 05:20:06 ohara Exp $ */ /* Copyright (C) Katsuyoshi OHARA, 2000. @@ -18,22 +18,58 @@ #include "mlo.h" #include "sm.h" +static int send_mlo_int32(cmo *m); +static int send_mlo_string(cmo *m); +static int send_mlo_zz(cmo *m); +static int send_mlo_list(cmo *c); + +static mlo *ml_read_returnpacket(); +static int ml_read_menupacket(); +static int ml_read_textpacket(); +static int ml_clear_interruption(); +static int ml_clear_abortion(); +static mlo *ml_return0(); + +static int ml_current_packet = -1; + +static double mathkernel_version; +static char *mathkernel_versionstring = NULL; + /* If this flag sets then we identify MLTKSYM to CMO_INDETERMINATE. */ int flag_mlo_symbol = FLAG_MLTKSYM_IS_INDETERMINATE; /* MLINK is a indentifier of MathLink connection. */ MLINK stdlink; +static unsigned flag_ml_state = 0; + +/* state management for the OpenXM robust interruption */ +unsigned ml_state_set(unsigned fl) +{ + return flag_ml_state |= fl; +} + +unsigned ml_state_clear(unsigned fl) +{ + return flag_ml_state &= ~fl; +} + +unsigned ml_state(unsigned fl) +{ + return (flag_ml_state & fl); +} + +void ml_state_clear_all() +{ + flag_ml_state = 0; +} + mlo *receive_mlo_real() { - char *s; - cmo *ob; - /* Yet we have no implementation of CMO_DOUBLE... */ - MLGetString(stdlink, &s); - ox_printf("MLTKREAL(%s)", s); - ob = (cmo *)new_cmo_string(s); - MLDisownString(stdlink, s); - return ob; + double d; + MLGetReal(stdlink, &d); + ox_printf("%lf", d); + return new_cmo_double(d); } mlo *receive_mlo_error() @@ -42,7 +78,7 @@ mlo *receive_mlo_error() char *s = MLErrorMessage(stdlink); MLClearError(stdlink); ox_printf("MLTKERR(%d,\"%s\")", errcode, s); - return (cmo *)make_error_object(ERROR_ID_FAILURE_MLINK, new_cmo_string(s)); + return (cmo *)make_error_object(errcode, new_cmo_string(s)); } mlo *receive_mlo_zz() @@ -51,8 +87,12 @@ mlo *receive_mlo_zz() mlo *m; MLGetString(stdlink, &s); - ox_printf("MLTKINT(%s)", s); + ox_printf("%s", s); +#if defined(WITH_GMP) m = (mlo *)new_cmo_zz_set_string(s); +#else + m = (mlo *)new_cmo_int32(atoi(s)); +#endif /* WITH_GMP */ MLDisownString(stdlink, s); return m; } @@ -62,7 +102,7 @@ mlo *receive_mlo_string() char *s; mlo *m; MLGetString(stdlink, &s); - ox_printf("MLTKSTR(\"%s\")", s); + ox_printf("\"%s\"", s); m = (cmo *)new_cmo_string(s); MLDisownString(stdlink, s); return m; @@ -76,17 +116,16 @@ cmo *receive_mlo_function() int i,n; MLGetFunction(stdlink, &s, &n); - ox_printf("MLTKFUNC(%s[#%d])", s, n); - m = new_cmo_list(); + ox_printf("%s#%d[", s, n); + m = (cmo *)new_cmo_list(); list_append((cmo_list *)m, new_cmo_string(s)); for (i=0; id; + ml_evaluateStringByLocalParser("$Version"); + mathkernel_versionstring = ((cmo_string *)ml_return())->s; + ox_printf("Mathematica %lf <%s>\n", + mathkernel_version, mathkernel_versionstring); return 0; } @@ -174,13 +220,17 @@ int ml_exit() MLClose(stdlink); } -/* Never forget call ml_select() before calling receive_mlo(). */ +/* Remember calling ml_select() before ml_return(). */ int ml_select() { - /* skip any packets before the first ReturnPacket */ - while (MLNextPacket(stdlink) != RETURNPKT) { + int i=0; + MLFlush(stdlink); + while(!MLReady(stdlink)) { + if (i==0 && ml_state(RESERVE_INTERRUPTION)) { + ml_interrupt(); + i++; + } usleep(10); - MLNewPacket(stdlink); } } @@ -196,36 +246,35 @@ cmo *receive_mlo() switch(type) { case MLTKINT: - return receive_mlo_zz(); + return (cmo *)receive_mlo_zz(); case MLTKSTR: - return receive_mlo_string(); + return (cmo *)receive_mlo_string(); case MLTKREAL: - return receive_mlo_real(); + return (cmo *)receive_mlo_real(); case MLTKSYM: - return receive_mlo_symbol(); + return (cmo *)receive_mlo_symbol(); case MLTKFUNC: - return receive_mlo_function(); + return (cmo *)receive_mlo_function(); case MLTKERR: - ox_printf("MLTKERR()"); - return (cmo *)make_error_object(ERROR_ID_FAILURE_MLINK, new_cmo_null()); + return (cmo *)receive_mlo_error(); default: - ox_printf("MLO is broken?(%d)", type); + ox_printf("broken MLO\(%d)", type); return NULL; } } -int send_mlo_int32(cmo *m) +static int send_mlo_int32(cmo *m) { MLPutInteger(stdlink, ((cmo_int32 *)m)->i); } -int send_mlo_string(cmo *m) +static int send_mlo_string(cmo *m) { char *s = ((cmo_string *)m)->s; MLPutString(stdlink, s); } -int send_mlo_zz(cmo *m) +static int send_mlo_zz(cmo *m) { char *s; MLPutFunction(stdlink, "ToExpression", 1); @@ -233,9 +282,8 @@ int send_mlo_zz(cmo *m) MLPutString(stdlink, s); } -int send_mlo_list(cmo *c) +static int send_mlo_list(cmo *c) { - char *s; cell *cp = list_first((cmo_list *)c); int len = list_length((cmo_list *)c); @@ -248,7 +296,6 @@ int send_mlo_list(cmo *c) int send_mlo(cmo *m) { - char *s; switch(m->tag) { case CMO_INT32: send_mlo_int32(m); @@ -271,8 +318,7 @@ int send_mlo(cmo *m) break; default: MLPutFunction(stdlink, "ToExpression", 1); - s = new_string_set_cmo(m); - MLPutString(stdlink, s); + MLPutString(stdlink, new_string_set_cmo(m)); break; } } @@ -295,4 +341,198 @@ int ml_executeFunction(char *function, int argc, cmo * send_mlo(argv[i]); } MLEndPacket(stdlink); +} + +int ml_next_packet() +{ + if (ml_current_packet < 0) { + ml_current_packet = MLNextPacket(stdlink); + ox_printf("PKT=%d ", ml_current_packet); + } + return ml_current_packet; +} + +int ml_new_packet() +{ + ml_current_packet = -1; + MLNewPacket(stdlink); +} + +/* Remember calling ml_new_packet() after ml_read_packet(). */ +int ml_read_packet() +{ + int pkt = ml_next_packet(); + switch(pkt) { + case MENUPKT: + ml_read_menupacket(); + break; + case TEXTPKT: + ml_read_textpacket(); + break; + case RETURNPKT: + ml_read_returnpacket(); + break; + case INPUTNAMEPKT: + ox_printf("INPUTNAMEPKT[]"); + break; + case ILLEGALPKT: + ox_printf("ILLEGALPKT[]"); + break; + case SUSPENDPKT: + ox_printf("SUSPENDPKT[]"); + break; + case RESUMEPKT: + ox_printf("RESUMEPKT[]"); + break; + default: + } + ox_printf("\n"); + return pkt; +} + +static mlo *ml_read_returnpacket() +{ + mlo *ob; + ox_printf("RETURNPKT["); + ob=receive_mlo(); + ox_printf("]"); + + return ob; +} + +static int ml_read_menupacket() +{ + ox_printf("MENUPKT["); + receive_mlo(); + ox_printf(", "); + receive_mlo(); + ox_printf("]"); +} + +static int ml_read_textpacket() +{ + char *s; + int type = MLGetNext(stdlink); + if (type == MLTKSTR) { + MLGetString(stdlink, &s); + ox_printf("TEXTPKT[\"%s\"]", s); + MLDisownString(stdlink, s); + }else { + ox_printf("TEXTPKT is broken? (%d)", type); + } +} + +/* References: +[1] Todd Gayley: "Re: How to interrupt a running evaluation in MathLink", +http://forums.wolfram.com/mathgroup/archive/1999/Apr/msg00174.html + +From: tgayley@linkobjects.com (Todd Gayley) +To: mathgroup@smc.vnet.net +Subject: [mg17015] Re: How to interrupt a running evaluation in MathLink +*/ + +int ml_interrupt() +{ + /* On UNIX, the MLPutMessage(process, MLInterruptMessage) + sends ``SIGINT" to the process running on the local machine. */ + MLPutMessage(stdlink, MLInterruptMessage); + ml_state_set(INTERRUPTED); +} + +/* Remark: +read MENUPKT[MLTKINT(1), MLTKSTR("Interrupt> ")] +write "\n" +read MENUPKT[MLTKINT(0), MLTKSTR("Interrupt> ")] +write "a" +read TEXTPKT[Your options are: + abort (or a) to abort current calculation + continue (or c) to continue + exit (or quit) to exit Mathematica + inspect (or i) to enter an interactive dialog + show (or s) to show current operation (and then continue) + trace (or t) to show all operations +] +*/ + +static int ml_clear_interruption() +{ + if (ml_read_packet() == MENUPKT) { + MLPutString(stdlink, "\n"); + ox_printf("MLPutString(\"\\n\");\n"); + ml_new_packet(); + if(ml_read_packet() == MENUPKT) { + MLPutString(stdlink, "a"); + ox_printf("MLPutString(\"a\");\n"); + ml_new_packet(); + if(ml_read_packet() == TEXTPKT) { + ml_new_packet(); + ox_printf("\n---END of ml_clear_interruption()---\n"); + return 0; /* success */ + } + } + } + ml_new_packet(); + ox_printf("Ooops!\n"); + return -1; +} + +int ml_abort() +{ + MLPutMessage(stdlink, MLAbortMessage); + ml_state_set(ABORTED); +} + +/* broken */ +static int ml_clear_abortion() +{ + while(ml_read_packet()==MENUPKT) { + ml_new_packet(); + } + MLPutString(stdlink, "a"); + ml_new_packet(); + ox_printf("aborted.\n"); + if (MLError(stdlink)) { + ox_printf("MLError=%s\n", MLErrorMessage(stdlink)); + } + receive_mlo(); + ml_state_clear_all(); +} + +static mlo *ml_return0() +{ + mlo *ob; + int pkt; + /* seeking to RETURNPKT */ + while((pkt = ml_next_packet()) != RETURNPKT) { + if (pkt == ILLEGALPKT) { + ob = receive_mlo_error(); + ml_new_packet(); /* OK? */ + return ob; + } + ml_read_packet(); /* debug only */ + ml_new_packet(); + } + ob = ml_read_returnpacket(); + ml_new_packet(); + ox_printf("\n---END of ml_return0()---\n"); + return ob; +} + +mlo *ml_return() +{ + mlo *ob; + if (ml_state(INTERRUPTED)) { + if (ml_next_packet() == RETURNPKT) { + /* a computation has done before the interruption */ + ob = ml_return0(); + ml_clear_interruption(); + }else { + ml_clear_interruption(); + MLFlush(stdlink); /* need for 4.x */ + ob = ml_return0(); /* ReturnPacket[$Aborted] */ + } + }else { + ob = ml_return0(); + } + return ob; }