@* ml. This file is based on mprep output.
 (mprep V2.2 (c) Copyright Wolfram Research, Inc. 1990-1993)
%\RCSID $Id: ml.w,v 1.13 1996/11/13 01:55:40 tjchol01 Exp tjchol01 $

@
@(../include/ml.h@>=
#ifndef __ML__
#define __ML__

#include <mathlink.h>
#include <tjc.h>                                /* Real definitions */

@<Macros@>@;
@<Typedefs@>@;
@<Prototypes@>@;
@<Variables@>@;
#endif


@ @<Macros@>=
#undef MLGetReal
#undef MLPutReal
#define MLGetReal CCAT2 (MLGet, Real)
#define MLPutReal CCAT2 (MLPut, Real)

#define MLGetRealList(stdlink, x, nx)  ERROR
#define MLPutRealList(stdlink, x, nx)  ERROR

#undef MLGetRealArray
#undef MLPutRealArray
#undef MLDisownRealArray
#define MLGetRealArray CCAT3 (MLGet, Real, Array)
#define MLPutRealArray CCAT3 (MLPut, Real, Array)
#define MLDisownRealArray CCAT3 (MLDisown, Real, Array)


#define MLPRINT(stmts) \
    MLPutFunction (stdlink, "EvaluatePacket", 1L) && \
        MLPutFunction (stdlink, "WriteString", 2) && \
            MLPutSymbol (stdlink, "$Output") && \
            MLPutFunction (stdlink, "OutputForm", 1) && \
            stmts && \
    MLNextPacket (stdlink) &&                   /* open result packet */ \
    MLNewPacket (stdlink)                       /* discard */


@ @<Typedefs@>=
struct ml_func {
    int (*f_func) (void);
	const char *f_patt;
    const char *f_args;
    int f_nargs;
    const char *f_usage;
};

typedef const struct ml_func ml_func_table[];
typedef const char *ml_messages_table[];


@ @<Variables@>=
extern int quit_flag;                           /* for |SIGQUIT| */
extern int fpe_flag;                            /* for |SIGFPE| */
extern ml_func_table ml_functions;              /* |NULL| terminated */
extern ml_messages_table ml_messages;           /* |NULL| terminated */

@ ml.c
@c
#include <stdio.h>                             /* |stderr| */
#include <stdlib.h>                            /* |malloc| */
#include <stdarg.h>                             /* |va_arg| */
#include <signal.h>                             /* |signal| */
#include <unistd.h>                             /* |dup| */
#include <string.h>

#ifdef sgi
#include <sigfpe.h>
int __fpe_trap_type (void);
#endif

#include <tjc.h>                                /* |UNUSED| */
#include <ml.h>                                 /* requires |Real| definition */
#ifdef IMSL
#include <imsl.h>
#endif


int MLAbort = 0;
int MLDone = 0;
MLINK stdlink;

int ml_functions_count = 0;     /* number of defined functions set in MLInstall */

int _definepattern (MLINK mlp, const char *patt, const char *args, int func_n);
int _MLDoCallPacket (MLINK mlp, ml_func_table functable, int nfuncs);
int _MLMainStep (MLINK mlp, ml_func_table functable, int nfuncs);

int quit_flag = 0;                              /* for |SIGQUIT| */
int fpe_flag = 0;                               /* for |SIGFPE| */

@<read real list@>@;
@<write real list@>@#
@<read real array@>@;
@<read real mat@>@;
@<write real array@>@#
@<write real tab@>@#

@<write int array@>@#
@<write int rows@>@#

@<MLerror@>@;
@<quit handler@>@;
#ifdef sgi
@<fpe handler@>@;
#endif
@<io handler@>@;
@<main@>@;


@
@d MAX_FUNC_USAGE_LEN 2000
@c
int MLInstall (MLINK mlp) {
	int _res, i;
    const struct ml_func *func;
    const char **message;

	_res = MLConnect (mlp);
    for (i = 0, func = ml_functions; _res && func->f_func; func++, i++) {
        _res = _definepattern (mlp, func->f_patt, func->f_args, i);
        if (_res) {
            char fusage[MAX_FUNC_USAGE_LEN];
            const char *brack = strchr (func->f_patt, '[');
            if (brack) {
                strncpy (fusage, func->f_patt, brack - func->f_patt);
                fusage[brack - func->f_patt] = '\0';
                strcat (fusage, "::usage = \"");
                strcat (fusage, func->f_patt);
                strcat (fusage, ": ");
                strcat (fusage, func->f_usage);
                strcat (fusage, "\"");
                _res = MLPutString (mlp, fusage);
            } else
                _res = 0;
        }
    }
    ml_functions_count = i;

    for (message = ml_messages; _res && *message; message++) {
        _res = MLPutString (mlp, *message);
    }
    _res = _res && MLPutString (mlp,
                                "Unprotect[General]\n"
                                "General::mlink=\"There has been a"
                                "low-level MathLink error. The message is: `1`\"\n"
                                "Protect[General]\n"
                                "MLprintfForm = NumberForm[#, 3,"
                                "ExponentFunction->(If[Abs[#] > 10, #, Null]&)]&\n");

    if (_res)
		_res = MLPutSymbol (mlp, "End") && MLFlush (mlp);
	return _res;
}


@ @c
int MLDoCallPacket (MLINK mlp) {
	return _MLDoCallPacket (mlp, ml_functions, ml_functions_count);
}

@ @c
int MLMainStep (MLINK mlp) {
	return _MLMainStep (mlp, ml_functions, ml_functions_count);
}

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

@ @c
int _MLDoCallPacket (MLINK mlp, ml_func_table functable, int nfuncs) {
	long len;
	int n, res = 0;
	const struct ml_func *funcp;

	if (!MLGetInteger (mlp, &n) || n < 0 || n >= nfuncs)
		goto L0;
	funcp = &functable[n];

	if (!MLCheckFunction (mlp, "List", &len) || len != funcp->f_nargs)
		goto L0;

	stdlink = mlp;
	res = (*funcp->f_func) ();

L0: if (res == 0)
		res = MLClearError (mlp) && MLPutSymbol (mlp, "$Failed");
	return res && MLEndPacket (mlp) && MLNewPacket (mlp);
}

@ @c
int MLAnswer (MLINK mlp) {
	int pkt = 0;

	while (!MLDone && !MLError (mlp) && (pkt = MLNextPacket (mlp)) && pkt == CALLPKT) {
		MLAbort = 0;
		if (!MLDoCallPacket (mlp))
			pkt = 0;
	}
	MLAbort = 0;
	return pkt;
}


@ @c
int _MLMainStep (MLINK mlp, ml_func_table functable, int nfuncs) {
	long len;
	int res = 0;

	if (MLCheckFunction (mlp, "CallPacket", &len))
		res = _MLDoCallPacket (mlp, functable, nfuncs);
	return res;
}

@ This function sends the following code to \Mma{}:
\begin{verbatim}
   Module[ { me = $ParentLink},
   $ParentLink = contents of RESUMEPKT;
   Message[ MessageName[$ParentLink, "notfe"], me];
   me]
\end{verbatim}
@c
int refuse_to_be_a_frontend (MLINK mlp) {
	int pkt;

	MLPutFunction (mlp, "EvaluatePacket", 1);
	MLPutFunction (mlp, "Module", 2); @+ {
		MLPutFunction (mlp, "List", 1); @+ {
			MLPutFunction (mlp, "Set", 2); @+ {
				MLPutSymbol (mlp, "me");
				MLPutSymbol (mlp, "$ParentLink");
			}
		}
		MLPutFunction (mlp, "CompoundExpression", 3); @+ {
			MLPutFunction (mlp, "Set", 2); @+ {
				MLPutSymbol (mlp, "$ParentLink");
				MLTransferExpression (mlp, mlp);
			}
			MLPutFunction (mlp, "Message", 2); @+ {
				MLPutFunction (mlp, "MessageName", 2); @+ {
					MLPutSymbol (mlp, "$ParentLink");
					MLPutString (mlp, "notfe");
				}
				MLPutSymbol (mlp, "me");
			}
			MLPutSymbol (mlp, "me");
		}
	}

	while ((pkt = MLNextPacket (mlp)) && pkt != SUSPENDPKT)
		MLNewPacket (mlp);
	MLNewPacket (mlp);
	return MLError (mlp) == MLEOK;
}

@ @c
int MLEvaluate (MLINK mlp, char *s) {
	if (MLAbort)
		return 0;
	return MLPutFunction (mlp, "EvaluatePacket", 1L)
		&& MLPutFunction (mlp, "ToExpression", 1L)
		&& MLPutString (mlp, s);
}


@ @c
void MLDefaultHandler (MLINK UNUSED (mlp), unsigned long message,
                       unsigned long UNUSED (n)) {
	switch ((int) message) {
	case MLTerminateMessage:
		MLDone = 1;
	case MLInterruptMessage:
	case MLAbortMessage:
		MLAbort = 1;
	default:
		return;
	}
}


@ @c
int MLMain (int argc, char *argv[]) {
	MLEnvironment ep;
	MLINK mlp;

	if ((ep = MLInitialize ((MLParametersPointer) 0)) == (MLEnvironment) 0)
		return 3;
	if ((mlp = MLOpen (argc, argv)) == (MLINK) 0)
		return 2;
	MLSetMessageHandler (mlp, MLCreateMessageHandler (ep, MLDefaultHandler, 0));
	if (MLInstall (mlp)) {
#if 0
        signal (SIGIO, io_handler);             /* !!! */
#endif

		while (MLAnswer (mlp) == RESUMEPKT) {
			if (!refuse_to_be_a_frontend (mlp))
				break;
		}
    }
	MLClose (mlp);

	return !MLDone;
}


@ %===================================================================
@<Prototypes@>=
int read_real_list (real **x, int *_nx);
@ @<read real list@>=
int read_real_list (real **_x, int *nx) {
    long n;
    int i;
    real *x;

    if (!MLCheckFunction (stdlink, "List", &n))
        return MLerror ("readlist::nolist");
    if (n == 0)
        x = NULL;
    else {
        x = (real *) malloc (sizeof (real) * n);
        for (i = 0; i < n; i++)
            if (!MLGetReal (stdlink, &x[i]))
                return 0;
    }
    *_x = x;
    *nx = n;
    return 1;
}

@ @<Prototypes@>=
int write_real_list (const real *x, const int nx);
@ @<write real list@>=
int write_real_list (const real *x, const int nx) {
    int l;
    if (MLPutFunction (stdlink, "List", nx)) {
        for (l = 0; l < nx; l++)
            if (!MLPutReal (stdlink, x[l]))
                return 0;
    } else
        return 0;
    return 1;
}

@ @<Prototypes@>=
int read_real_array (real **array, int *_n, int *_m);
@ @<read real array@>=
int read_real_array (real **array, int *_n, int *_m) {
    real *a;            /* array */
    long *adims;        /* array dimensions */
    char **aheads;      /* array heads */
    long adepth;              /* array depths */
    int n, m;
    if (!MLGetRealArray (stdlink, &a, &adims, &aheads, &adepth) ||@|
        adepth != 2)
        return 0;
    n = adims[0];
    m = adims[1];
    if (n == 0 || m == 0) {
        n = m = 0;
        *array = NULL;
    } else {
        *array = (real *) malloc (sizeof (real) * n * m);
        memcpy (*array, a, n * m * sizeof (real));
    }
    MLDisownRealArray (stdlink, a, adims, aheads, adepth);
    *_n = n;
    *_m = m;
    return 1;
}

@ @<Prototypes@>=
int read_real_mat (real **mat);
@ @<read real mat@>=
int read_real_mat (real **mat) {
    real *a;                                    /* array */
    long *adims;                                /* array dimensions */
    char **aheads;                              /* array heads */
    long adepth;                                /* array depths */
    int n, m;
    if (!MLGetRealArray (stdlink, &a, &adims, &aheads, &adepth) ||@|
        adepth != 2)
        return 0;
    n = adims[0];
    m = adims[1];
    if (n == 0 || m == 0) {
        n = m = 0;
        *mat = NULL;
    } else {
        *mat = alloc_copy_real_mat (n, m, a);
    }
    MLDisownRealArray (stdlink, a, adims, aheads, adepth);
    return 1;
}

@ @<Prototypes@>=
int write_real_array (real *x, const int n, const int m);
@ @<write real array@>=
int write_real_array (real *x, const int n, const int m) {
    long xdims[2];
    xdims[0] = n;
    xdims[1] = m;
    if (n <= 0 || m <= 0)
        return MLPutFunction (stdlink, "List", 0);
    else
        return MLPutRealArray (stdlink, x, xdims, NULL, 2);
}

@ @<Prototypes@>=
int write_real_tab (real **x);
@ @<write real tab@>=
int write_real_tab (real **x) {
    int i, n;
    n = TAB_ROWS (x);
    MLPutFunction (stdlink, "List", n);
    for (i = 0; i < n; i++)
        if (!write_real_list (x[i], TAB_TYPE (x) == tab_rows
                              ? ROW_COLS (x)[i] : MAT_COLS (x) ))
            return 0;
    return 1;
}

@ @<Prototypes@>=
int write_int_array (int *x, const int n, const int m);
@ @<write int array@>=
int write_int_array (int *x, const int n, const int m) {
    long xdims[2];
    xdims[0] = n;
    xdims[1] = m;
    if (n <= 0 || m <= 0)
        return MLPutFunction (stdlink, "List", 0);
    else
        return MLPutIntegerArray (stdlink, x, xdims, NULL, 2);
}

@ @<Prototypes@>=
int write_int_rows (int **x, const int *l, const int m);
@ @<write int rows@>=
int write_int_rows (int **x, const int *l, const int m) {
    int i;
    MLPutFunction (stdlink, "List", m);
    for (i = 0; i < m; i++)
        if (!MLPutIntegerList (stdlink, x[i], l[i]))
            return 0;
    return 1;
}


@ MLerror.
@<Prototypes@>=
int MLerror (const char *msg);
@ @<MLerror@>=
int MLerror (const char *msg) {
    char err_msg[200];

    sprintf (err_msg, "Message[%s, \"%.76s\"]", msg, MLErrorMessage (stdlink));
    MLClearError (stdlink);
    MLNewPacket (stdlink);
    MLEvaluate (stdlink, err_msg);
    MLNextPacket (stdlink);
    MLNewPacket (stdlink);
    return 0;
}


@ @<Prototypes@>=
int MLprintf (const char *fmt, ...);
@
@d FMTCHARS  "idfgsAaBbCcXxYyZz"
@c
int MLprintf (const char *fmt, ...) {
    va_list argp;
    char *msg, *msgpos;
    const char *f;
    int pcnt = 0;
    int instr = 0;

    for (f = fmt; *f; f++) {                    /* count |Print[]| arguments */
        if (*f == '%') {
            f++;
            if (*f == '%')
                instr = 1;
            else
                if (strchr (FMTCHARS, *f)) {
                    pcnt++;
                    if (instr)
                        pcnt++;
                    instr = 0;
                } else
                    return MLerror ("MLprintf::badchar");
        } else {
            instr = 1;
        }
    }
    if (instr)
        pcnt++;

    if (!MLPutFunction (stdlink, "EvaluatePacket", 1L) ||@|
        !MLPutFunction (stdlink, "WriteString", 1 + pcnt) ||@|
        !MLPutSymbol (stdlink, "$Output"))
        return MLerror ("MLprintf::mlink");


    msg = (char *) malloc (strlen (fmt) + 1);   /* not longer than |fmt| */
    msgpos = msg;

    va_start (argp, fmt);

    for (f = fmt; *f; f++) {
        if (*f == '%') {
            f++;
            if (*f == '%') {
                *(msgpos++) = '%';
            } else {
                if (msgpos > msg) {
                    *msgpos = '\0';
                    MLPutString (stdlink, msg);
                    msgpos = msg;
                }

                if (!MLPutFunction (stdlink, "MLprintfForm", 1))
                    return MLerror ("MLprintf::mlink");

                switch (*f) {
                case 'i':
                case 'd':
                    MLPutInteger (stdlink, va_arg (argp, int));
                    break;
                case 'f':
                case 'g':
                    if (!MLPutFunction (stdlink, "CForm", 1))
                        return MLerror ("MLprintf::mlink");

                    MLPutReal (stdlink, va_arg (argp, double));
                    break;
                case 's':
                    MLPutFunction (stdlink, "OutputForm", 1); /* wrap */
                    MLPutString (stdlink, va_arg (argp, char *));
                    break;

                case 'A':
                case 'a':
                    MLPutIntegerList (stdlink, va_arg (argp, int *), va_arg (argp, int));
                    break;

                case 'B':
                    MLPutFunction (stdlink, "MatrixForm", 1);
                case 'b':
                    write_int_array (va_arg (argp, int *),
                                     va_arg (argp, int), va_arg (argp, int));
                    break;

                case 'C':
                    MLPutFunction (stdlink, "MatrixForm", 1);
                case 'c':
                    write_int_rows (va_arg (argp, int **),
                                    va_arg (argp, int *), va_arg (argp, int));
                    break;

                case 'X':
                    MLPutFunction (stdlink, "OutputForm", 1);
                case 'x':
                    write_real_list (va_arg (argp, real *), va_arg (argp, int));
                    break;

                case 'Y':
                    MLPutFunction (stdlink, "MatrixForm", 1);
                case 'y':
                    write_real_array (va_arg (argp, real *),
                                      va_arg (argp, int), va_arg (argp, int));
                    break;

                case 'Z':
                    MLPutFunction (stdlink, "MatrixForm", 1);
                case 'z':
                    write_real_tab (va_arg (argp, real **));
                    break;


                default:
                    return MLerror ("MLprintf::badchar2");
                }
            }
        } else {
            *(msgpos++) = *f;
        }
    }
    if (msgpos > msg) {                         /* string left to print */
        *msgpos = '\0';
        MLPutString (stdlink, msg);
    }

    va_end (argp);
    free (msg);

    return (MLNextPacket (stdlink) &&           /* open result packet */ \
            MLNewPacket (stdlink));              /* discard */

}


@ QUIT signal handler can be used for graceful interrupting calculations.
@<quit handler@>=
void quit_handler (int UNUSED (p)) {
    quit_flag = 1;
    MLprintf ("SIGQUIT!\n");
    signal (SIGQUIT, quit_handler);
}

@ FPE signal handler detects overflows.  Underflows are not handled. SGI only.
@<fpe handler@>=
int fpe_handler (int UNUSED (sig), int UNUSED (code),
                 struct sigcontext * UNUSED (sc)) {

    if (!fpe_flag) {
        const char *msg[] = {"underflow", "overflow",
                             "division by zero", "invalid", "int overflow"};
        int type = __fpe_trap_type ();
        if (1 <= type && type <= LEN (msg))
            MLprintf ("SIGFPE: %s\n", msg[type - 1]);
        else
            MLprintf ("SIGFPE: unknown type %d\n", type);
        fpe_flag = 1;                           /* suggest exit */
    }

    return 0;                                   /* continue */
}

@ IO signal handler.  \ML{} sends SIGIO when uninstalling program.
@<io handler@>=
void io_handler (int UNUSED (p)) {
    MLDone = 1;
    MLAbort = 1;
    signal (SIGIO, io_handler);
}

@ Main function
@<main@>=
int main (int argc, char *argv[]) {
#ifdef IMSL
    const int n = -2;
    int nunit = dup (fileno (stderr)) + 1;
    const int ipact = 1, isact = 0;
    /* redirect \IMSL{} error messages from stdout to stderr */
    umach (&n, &nunit);
    /* set printing and no stopping for all errors */
    erset (&IMSLS_ALL, &ipact, &isact);
#endif

#if 0
    signal (SIGQUIT, quit_handler);
#ifdef sgi
    handle_sigfpes (_ON, _EN_OVERFL | _EN_DIVZERO | _EN_INVALID |
                    _EN_INT_OVERFL, 0, _USER_HANDLER, (abort_t) fpe_handler);
                                                /* |_EN_UNDERFL| not handled */
#endif
#endif

    return MLMain(argc, argv);
}

@
\vfill
\begin{rcslog}
$Log: ml.w,v $
\Revision 1.13  1996/11/13 01:55:40  tjchol01
Adapted to 3.0.

\Revision 1.12  1996/10/30 00:36:51  tjchol01
Print FPE warnings only the first time.

\Revision 1.11  1996/10/29 05:35:06  tjchol01
FPE write descriptions using |MLprintf|.

\Revision 1.10  1996/10/27 23:30:37  tjchol01
Added FPE and IO handling for SGI,
    |read_real_list| returns |NULL|, corrected |strlen| bug in |MLprintf|.

\Revision 1.9  1996/10/24 06:23:43  tjchol01
|read_real_array| return |NULL| for empty arrays.

\Revision 1.8  1996/10/21 21:49:22  tjchol01
First version of |MLprintf|.

\Revision 1.7  1996/10/04  00:27:28  tjchol01
Macro |MLPRINT|.

\Revision 1.6  1996/10/01  22:46:30  tjchol01
Added |MLprintf|, removed |MLmessage|.

\Revision 1.5  1996/09/29 18:03:33  tjchol01
|Real| and |CCAT| macros moved to tjc.w.

\Revision 1.4  1996/09/11 03:51:17  tjchol01
Removed duplicate Failed from |MLerror|.  Added |show_list| functions.

\Revision 1.3  1996/05/05 03:35:58  tjchol01
Moved all \ML{} specific contents from |tjc.w| here.

\Revision 1.2  1996/05/02 06:22:25  tjchol01
Working and used by scg.w.

\Revision 1.1  1996/05/01 01:45:03  tjchol01
First sketch.  Converted to ANSI.
\endrcslog
@