/* AIX requires this to be the first thing in the file. */
#ifndef __GNUC__
# if HAVE_ALLOCA_H
# include <alloca.h>
# else
# ifdef _AIX
#pragma alloca
# else
# ifndef alloca /* predefined by HP cc +Olibcalls */
char *alloca ();
# endif
# endif
# endif
#endif
/* This file is part of the Q programming system.
The Q programming system is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
The Q programming system is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
#if defined (HAVE_CONFIG_H)
# include "config.h"
#endif
/* system headers */
#include <stdio.h>
#include <ctype.h>
#include <signal.h>
#include <math.h>
/* check for standard C headers */
#if STDC_HEADERS
# include <stdlib.h>
# include <string.h>
#else
# ifndef HAVE_STRCHR
# define strchr index
# define strrchr rindex
# endif
char *strchr (), *strrchr ();
#endif
#ifdef HAVE_MALLOC_H
#include <stdlib.h>
#endif
#ifdef HAVE_LIMITS_H
#include <limits.h>
#endif
#if TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#else
# if HAVE_SYS_TIME_H
# include <sys/time.h>
# else
# include <time.h>
# endif
#endif
#include <sys/types.h>
#if HAVE_SYS_WAIT_H
# include <sys/wait.h>
#endif
#ifndef WEXITSTATUS
# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
#endif
#ifndef WIFEXITED
# define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef WIN32
#include <windows.h>
#endif
#include <libq.h>
#ifdef DMALLOC
#include <dmalloc.h>
#endif
#ifdef WORDS_BIGENDIAN
static const char endian = 'B';
#else
static const char endian = 'L';
#endif
#define magic_len 10
MODULE(octave)
#ifndef HAVE_STRDUP
static char *strdup(char *s)
{
char *t;
return ((t=malloc(strlen(s)+1))?strcpy(t, s):NULL);
}
#endif
FILE *octp = NULL; /* pipe to the interpreter */
#define bufsz 1024
/* This is only a default. You can change this in octave.q (OCTAVE
variable). */
static const char *octave_cmd = "octave -q -i -H";
static const char *octaverc = ".octaverc";
static const char *octaverc_bak = ".octaverc.$$$";
static int send_octave(char *);
/* handle SIGINT and SIGTERM */
#if RETSIGTYPE == void
#define SIGHANDLER_RETURN(status) return
#else
#define SIGHANDLER_RETURN(status) return status
#endif
#ifdef MUST_REINSTALL_SIGHANDLERS
#define SIGHANDLER_RESTORE(sig,handler) syssignal(sig,handler)
#else
#define SIGHANDLER_RESTORE(sig,handler) /* nop */
#endif
typedef RETSIGTYPE (*sighandler_t)(int);
static sighandler_t syssignal(sig, handler)
int sig;
sighandler_t handler;
{
#ifdef HAVE_POSIX_SIGNALS
struct sigaction new_action, old_action;
new_action.sa_handler = handler;
sigemptyset(&new_action.sa_mask);
sigemptyset(&old_action.sa_mask);
new_action.sa_flags = 0;
sigaction(sig, &new_action, &old_action);
return old_action.sa_handler;
#else
return signal(sig, handler);
#endif
}
static volatile int brkflag = 0;
static sighandler_t int_handler = NULL, term_handler = NULL,
hup_handler = NULL;
static RETSIGTYPE break_handler(int sig)
{
if (sig == SIGINT && int_handler) int_handler(sig);
if (sig == SIGTERM && term_handler) term_handler(sig);
#ifdef SIGHUP
if (sig == SIGHUP && hup_handler) hup_handler(sig);
#endif
SIGHANDLER_RESTORE(sig, break_handler);
brkflag = 1;
SIGHANDLER_RETURN(0);
}
#ifdef WIN32
/* win32 tmpnam is broken, provide a reasonable replacement */
#define tmpnam mytmpnam
static char *tmpnam(char *s)
{
static char *t = NULL;
char *p;
if (t) free(t);
t = _tempnam(NULL, "t");
if (!t) return NULL;
/* make sure to convert all \'s to /'s */
while ((p = strchr(t, '\\'))) *p = '/';
if (s) {
strcpy(s, t);
return s;
} else
return t;
}
#endif
/* take a short sleep (approx 1/100 secs) */
static void sleep_some(void)
{
#ifdef WIN32
Sleep(10);
#else
#ifdef HAVE_NANOSLEEP
struct timespec req;
req.tv_sec = 0; req.tv_nsec = 10000000;
nanosleep(&req, NULL);
#else
#ifdef HAVE_USLEEP
usleep(10000);
#else
sleep(1);
#endif
#endif
#endif
}
/* recent beta versions of octave have a different save type byte for doubles
-- we check this here */
static signed char st = 7; // this is the value from octave 2.0.x
static beta_check(int d)
{
char magic[magic_len+1], magic1[magic_len+1];
signed char f, t, st1;
int l, r, c;
void *buf;
/* magic header */
sprintf(magic, "Octave-1-%c", endian);
if (read(d, magic1, magic_len) < magic_len) return 0;
magic1[magic_len] = 0;
if (strcmp(magic, magic1)) return 0; /* wrong magic */
/* float format */
if (read(d, &f, 1) < 1) return 0;
if (f != 0) return 0; /* don't care about single precision format */
/* name length */
if (read(d, &l, sizeof(l)) < sizeof(l)) return 0;
/* name string */
if (!(buf = malloc(l))) return 0;
if (read(d, buf, l) < l) { free(buf); return 0; }
free(buf);
/* doc length */
if (read(d, &l, sizeof(l)) < sizeof(l)) return 0;
/* doc string */
if (!(buf = malloc(l))) return 0;
if (read(d, buf, l) < l) { free(buf); return 0; }
free(buf);
/* global flag */
if (read(d, &f, 1) < 1) return 0;
/* type */
if (read(d, &t, 1) < 1) return 0;
if (t != 1 && t != 2 && t != 3 && t != 4) return 0; /* unknown type */
/* rows/columns */
if (t == 2 || t == 4) {
if (read(d, &r, sizeof(r)) < 1) return 0;
if (read(d, &c, sizeof(r)) < 1) return 0;
}
/* save type */
if (read(d, &st1, 1) < 1) return 0;
st = st1;
return 1;
}
static void start_octave(void)
{
FILE *fp, *fp2;
char buf[bufsz];
int bak = 0;
static int init = 0;
if (!octp) {
/* get the command from the OCTAVE variable if defined */
expr var = mksym(sym(OCTAVE)), res = NULL;
char *s = NULL, *t, *l, *c;
const char *octcmd;
const char *lock = ".lock";
/* this may look weird, but we have to check the save type byte to
support recent beta versions (see above) */
const char *ct =
"__t = 1; save -binary \"%s\" __t; clear __t; unlink \"%s\";";
if (var && (res = eval(var)) && isstr(res, &s) && (s = strdup(s)))
octcmd = s;
else
octcmd = octave_cmd;
if (res) dispose(res);
/* kludge: create a .octaverc file which sets all prompt strings
to zero */
if ((fp = fopen(octaverc, "r"))) {
/* make a backup copy of previous .octaverc */
bak = 1;
fclose(fp);
rename(octaverc, octaverc_bak);
}
if ((fp = fopen(octaverc, "w"))) {
fprintf(fp, "PS1 = PS2 = PS4 = \"\";\n");
if (bak && (fp2 = fopen(octaverc_bak, "r"))) {
/* copy contents of previous .octaverc */
while (fgets(buf, bufsz, fp2))
fprintf(fp, "%s", buf);
fclose(fp2);
}
if (ferror(fp)) {
fclose(fp); goto errexit;
} else if (fclose(fp))
goto errexit;
} else
goto errexit;
if (!(octp = popen(octcmd, "w"))) goto errexit;
/* register SIGINT and SIGTERM handlers */
if (!init) {
init = 1;
int_handler = syssignal(SIGINT, break_handler);
term_handler = syssignal(SIGTERM, break_handler);
#ifdef SIGHUP
hup_handler = syssignal(SIGHUP, break_handler);
#endif
}
/* wait for octave startup to finish */
t = tmpnam(NULL);
l = (char*)alloca(strlen(t)+strlen(lock)+1);
c = (char*)alloca(strlen(ct)+2*strlen(t)+strlen(lock)+1);
if (!t || !l || !c) goto errexit;
strcat(strcpy(l, t), lock);
if (!(fp = fopen(l, "w"))) goto errexit;
fclose(fp);
sprintf(c, ct, t, l);
if (!send_octave(c))
brkflag = 1;
else
brkflag = 0;
while (!brkflag && (fp = fopen(l, "r"))) {
fclose(fp);
release_lock();
sleep_some();
acquire_lock();
}
if (brkflag) {
brkflag = 0;
unlink(l); unlink(t);
pclose(octp);
octp = NULL;
} else {
/* get the save type byte */
if ((fp = fopen(t, "rb"))) {
beta_check(fileno(fp));
fclose(fp);
}
unlink(t);
}
errexit:
if (s) free(s);
unlink(octaverc);
if (bak) rename(octaverc_bak, octaverc);
}
}
static void stop_octave(void)
{
if (octp) {
fprintf(octp, "quit\n");
pclose(octp);
octp = NULL;
}
}
static int send_octave(char *cmd)
{
start_octave();
if (octp) {
fprintf(octp, "%s\n", cmd);
fflush(octp);
if (ferror(octp))
return 0;
else
return 1;
} else
return 0;
}
FUNCTION(octave,octave,argc,argv)
{
char *s;
if (argc == 1 && isstr(argv[0], &s)) {
if (send_octave(s))
return mkvoid;
else
return __FAIL;
} else
return __FAIL;
}
FUNCTION(octave,octave_quit,argc,argv)
{
if (argc == 0) {
stop_octave();
return mkvoid;
} else
return __FAIL;
}
static expr mkcomplex(double re, double im)
{
return mktuplel(2, mkfloat(re), mkfloat(im));
}
/* read Octave-1 binary format */
/* This doesn't support all the fancy octave binary file features, but should
be enough for our purposes. (FIXME: maybe we should handle little-endian
data on big-endian systems and vice versa?) */
static expr readdata(int d, char *magic)
{
char magic1[magic_len+1];
signed char f, t, st1;
int l, r, c;
void *buf;
/* magic header */
if (read(d, magic1, magic_len) < magic_len) return NULL;
magic1[magic_len] = 0;
if (strcmp(magic, magic1)) return NULL; /* wrong magic */
/* float format */
if (read(d, &f, 1) < 1) return NULL;
if (f != 0) return NULL; /* don't care about single precision format */
/* name length */
if (read(d, &l, sizeof(l)) < sizeof(l)) return NULL;
/* name string */
if (!(buf = malloc(l))) return NULL;
if (read(d, buf, l) < l) { free(buf); return NULL; }
free(buf);
/* doc length */
if (read(d, &l, sizeof(l)) < sizeof(l)) return NULL;
/* doc string */
if (!(buf = malloc(l))) return NULL;
if (read(d, buf, l) < l) { free(buf); return NULL; }
free(buf);
/* global flag */
if (read(d, &f, 1) < 1) return NULL;
/* type */
if (read(d, &t, 1) < 1) return NULL;
/* binary file format changed in recent octave versions */
if (t != 1 && t != 2 && t != 3 && t != 4 && t != -1)
return NULL; /* unknown type */
if (t == -1) {
char *buf;
/* type length */
if (read(d, &l, sizeof(l)) < sizeof(l)) return NULL;
/* type string */
if (!(buf = malloc(l+1))) return NULL;
if (read(d, buf, l) < l) { free(buf); return NULL; }
buf[l] = 0;
if (strcmp(buf, "scalar") == 0)
t = 1;
else if (strcmp(buf, "matrix") == 0)
t = 2;
else if (strcmp(buf, "complex scalar") == 0)
t = 3;
else if (strcmp(buf, "complex matrix") == 0)
t = 4;
free(buf);
if (t == -1) return NULL;
if (t == 2 || t == 4) {
/* matrix dimension (we expect 1 or 2 for now) */
int ndims;
if (read(d, &ndims, sizeof(ndims)) < sizeof(ndims)) return NULL;
ndims = -ndims;
if (ndims <= 0 || ndims > 2) return NULL;
/* rows/columns */
if (ndims == 1) {
r = 1;
if (read(d, &c, sizeof(c)) < 1) return NULL;
} else {
if (read(d, &r, sizeof(r)) < 1) return NULL;
if (read(d, &c, sizeof(c)) < 1) return NULL;
}
}
} else {
/* rows/columns */
if (t == 2 || t == 4) {
if (read(d, &r, sizeof(r)) < 1) return NULL;
if (read(d, &c, sizeof(c)) < 1) return NULL;
}
}
/* save type */
if (read(d, &st1, 1) < 1) return NULL;
if (st1 != st) return NULL; /* unrecognized format */
/* data */
switch (t) {
case 1: {
/* real */
double re;
if (read(d, &re, sizeof(re)) < sizeof(re)) return NULL;
return mkfloat(re);
}
case 3: {
/* complex */
double re, im;
if (read(d, &re, sizeof(re)) < sizeof(re)) return NULL;
if (read(d, &im, sizeof(im)) < sizeof(im)) return NULL;
return mkcomplex(re, im);
}
case 2: {
/* real matrix */
expr x = NULL;
buf = malloc(r*c*sizeof(double));
if (!buf) return NULL;
if (read(d, buf, r*c*sizeof(double)) < r*c*sizeof(double)) {
free(buf); return NULL;
}
if (r == 1) {
/* row vector */
double *v = (double*)buf;
expr *xs = malloc(c*sizeof(expr));
if (xs) {
int i;
for (i = 0; i < c; i++)
if (!(xs[i] = mkfloat(v[i]))) {
int j;
for (j = 0; j < i; j++)
dispose(xs[j]);
free(xs);
goto errexit;
}
if (!(x = mklistv(c, xs)))
goto errexit;
} else
goto errexit;
} else {
/* matrix */
double *v = (double*)buf;
expr *xs = malloc(r*sizeof(expr));
int *base = (int*)malloc(c*sizeof(int));
if (xs && base) {
int i, j, b;
for (b = j = 0; j < c; j++, b+= r)
base[j] = b;
for (i = 0; i < r; i++) {
expr *ys = (expr*)malloc(c*sizeof(expr));
if (!ys) {
int k;
for (k = 0; k < i; k++)
dispose(xs[k]);
free(xs); free(base);
goto errexit;
}
for (j = 0; j < c; j++)
if (!(ys[j] = mkfloat(v[base[j]+i]))) {
int k;
for (k = 0; k < j; k++)
dispose(ys[k]);
for (k = 0; k < i; k++)
dispose(xs[k]);
free(xs); free(ys); free(base);
goto errexit;
}
if (!(xs[i] = mklistv(c, ys))) {
int k;
for (k = 0; k < i; k++)
dispose(xs[k]);
free(xs); free(base);
goto errexit;
}
}
if (!(x = mklistv(r, xs))) {
free(base);
goto errexit;
}
free(base);
} else {
if (xs) free(xs);
if (base) free(base);
goto errexit;
}
}
errexit:
free(buf);
return x;
}
case 4: {
/* complex matrix */
expr x = NULL;
buf = malloc(2*r*c*sizeof(double));
if (!buf) return NULL;
if (read(d, buf, 2*r*c*sizeof(double)) < 2*r*c*sizeof(double)) {
free(buf); return NULL;
}
if (r == 1) {
/* row vector */
double *v = (double*)buf;
expr *xs = malloc(c*sizeof(expr));
if (xs) {
int i;
for (i = 0; i < c; i++)
if (!(xs[i] = mkfloat(v[i]))) {
int j;
for (j = 0; j < i; j++)
dispose(xs[j]);
free(xs);
goto errexit2;
}
if (!(x = mklistv(c, xs)))
goto errexit2;
} else
goto errexit2;
} else {
/* matrix */
double *v = (double*)buf;
expr *xs = malloc(r*sizeof(expr));
int *base = (int*)malloc(c*sizeof(int));
if (xs && base) {
int i, j, b;
for (b = j = 0; j < c; j++, b+=(r<<1))
base[j] = b;
for (i = 0; i < r; i++) {
expr *ys = malloc(c*sizeof(expr));
if (!ys) {
int k;
for (k = 0; k < i; k++)
dispose(xs[k]);
free(xs); free(base);
goto errexit2;
}
for (j = 0; j < c; j++)
if (!(ys[j] = mkcomplex(v[base[j]+(i<<1)], v[base[j]+(i<<1)+1]))) {
int k;
for (k = 0; k < j; k++)
dispose(ys[k]);
for (k = 0; k < i; k++)
dispose(xs[k]);
free(xs); free(ys); free(base);
goto errexit2;
}
if (!(xs[i] = mklistv(c, ys))) {
int k;
for (k = 0; k < i; k++)
dispose(xs[k]);
free(xs); free(base);
goto errexit2;
}
}
if (!(x = mklistv(r, xs))) {
free(base);
goto errexit2;
}
free(base);
} else {
if (xs) free(xs);
if (base) free(base);
goto errexit2;
}
}
errexit2:
free(buf);
return x;
}
}
}
FUNCTION(octave,octave_get,argc,argv)
{
char *s, magic[magic_len+1];
start_octave();
if (argc == 1 && isstr(argv[0], &s)) {
/* make a temporary file name */
char *t = tmpnam(NULL);
const char *lock = ".lock";
const char *cmd_template =
"save -binary -save-builtins \"%s\" %s; unlink \"%s\";";
char *l = (char*)alloca(strlen(t)+strlen(lock)+1);
char *c = (char*)alloca(strlen(cmd_template)+strlen(s)+2*strlen(t)+
strlen(lock)+1);
FILE *fp;
if (!t || !l || !c) return __FAIL;
strcat(strcpy(l, t), lock);
sprintf(magic, "Octave-1-%c", endian);
/* make octave save the variable in an Octave binary file, keep track
of when Octave finishes writing the file using a lock file */
if (!(fp = fopen(l, "w"))) return __FAIL;
fclose(fp);
sprintf(c, cmd_template, t, s, l);
brkflag = 0;
if (!send_octave(c)) brkflag = 1;
/* wait for Octave to complete the command */
while (!brkflag && (fp = fopen(l, "r"))) {
fclose(fp);
release_lock();
sleep_some();
acquire_lock();
}
if (brkflag) {
/* user interrupt, fail */
brkflag = 0;
unlink(t);
return __FAIL;
} else {
expr x = NULL;
/* done writing the file, get data */
if ((fp = fopen(t, "rb"))) {
x = readdata(fileno(fp), magic);
fclose(fp);
}
/* remove temporary file */
unlink(t);
return x?x:__FAIL;
}
} else
return __FAIL;
}
static isscalar(expr x, int *cplx, double *re, double *im)
{
double d;
int n;
expr *xs;
if (ismpz_float(x, &d)) {
*cplx = 0; *re = d; *im = 0.0;
return 1;
} else if (isfloat(x, &d)) {
*cplx = 0; *re = d; *im = 0.0;
return 1;
} else if (istuple(x, &n, &xs) && n == 2) {
if (ismpz_float(xs[0], &d))
*re = d;
else if (isfloat(xs[0], &d))
*re = d;
else
return 0;
if (ismpz_float(xs[1], &d))
*im = d;
else if (isfloat(xs[1], &d))
*im = d;
else
return 0;
*cplx = 1;
} else
return 0;
}
static isvector(expr x, int *cplx, int *c)
{
int cplx1;
expr hd, tl;
double re, im;
*c = 0;
*cplx = 0;
while (iscons(x, &hd, &tl))
if (isscalar(hd, &cplx1, &re, &im)) {
(*c)++;
*cplx = *cplx || cplx1;
x = tl;
} else
return 0;
return isnil(x);
}
static ismatrix(expr x, int *cplx, int *r, int *c)
{
int cplx1, c1;
expr hd, tl;
*r = 0; *c = -1;
*cplx = 0;
while (iscons(x, &hd, &tl))
if (isvector(hd, &cplx1, &c1)) {
(*r)++;
if (*c == -1)
*c = c1;
else if (*c != c1)
return 0;
*cplx = *cplx || cplx1;
x = tl;
} else
return 0;
return isnil(x);
}
/* write Octave-1 binary format */
/* FIXME: asserts that integers are always 4 bytes long */
static writescalar(int d, char *magic, char *name,
int cplx, double re, double im)
{
signed char f = 0, t = cplx?3:1;
int l = strlen(name);
/* magic header */
if (write(d, magic, magic_len) == -1) return 0;
/* float format */
if (write(d, &f, 1) == -1) return 0;
/* name length */
if (write(d, &l, sizeof(l)) == -1) return 0;
/* name */
if (write(d, name, l) == -1) return 0;
/* doc length */
l = 0;
if (write(d, &l, sizeof(l)) == -1) return 0;
/* global flag */
if (write(d, &f, 1) == -1) return 0;
/* scalar type */
if (write(d, &t, 1) == -1) return 0;
/* save type */
if (write(d, &st, 1) == -1) return 0;
/* data */
if (write(d, &re, sizeof(re)) == -1) return 0;
if (cplx && write(d, &im, sizeof(im)) == -1) return 0;
return 1;
}
static writevector(int d, char *magic, char *name,
int cplx, expr x, int c)
{
signed char f = 0, t = cplx?4:2;
int l = strlen(name), r = 1, cplx1;
double re, im;
expr hd, tl;
/* magic header */
if (write(d, magic, magic_len) == -1) return 0;
/* float format */
if (write(d, &f, 1) == -1) return 0;
/* name length */
if (write(d, &l, sizeof(l)) == -1) return 0;
/* name */
if (write(d, name, l) == -1) return 0;
/* doc length */
l = 0;
if (write(d, &l, sizeof(l)) == -1) return 0;
/* global flag */
if (write(d, &f, 1) == -1) return 0;
/* matrix type */
if (write(d, &t, 1) == -1) return 0;
/* rows/columns */
if (write(d, &r, sizeof(r)) == -1) return 0;
if (write(d, &c, sizeof(r)) == -1) return 0;
/* save type */
if (write(d, &st, 1) == -1) return 0;
/* data */
while (iscons(x, &hd, &tl)) {
if (isscalar(hd, &cplx1, &re, &im)) {
if (write(d, &re, sizeof(re)) == -1) return 0;
if (cplx && write(d, &im, sizeof(im)) == -1) return 0;
} else /* shouldn't happen */
return 0;
x = tl;
}
if (!isnil(x)) return 0; /* shouldn't happen */
return 1;
}
static writematrix(int d, char *magic, char *name,
int cplx, expr x, int r, int c)
{
signed char f = 0, t = cplx?4:2;
int l = strlen(name), cplx1, i, j;
double re, im;
expr *rows = (expr*)alloca(r*sizeof(expr)), hd, tl;
/* magic header */
if (write(d, magic, magic_len) == -1) return 0;
/* float format */
if (write(d, &f, 1) == -1) return 0;
/* name length */
if (write(d, &l, sizeof(l)) == -1) return 0;
/* name */
if (write(d, name, l) == -1) return 0;
/* doc length */
l = 0;
if (write(d, &l, sizeof(l)) == -1) return 0;
/* global flag */
if (write(d, &f, 1) == -1) return 0;
/* matrix type */
if (write(d, &t, 1) == -1) return 0;
/* rows/columns */
if (write(d, &r, sizeof(r)) == -1) return 0;
if (write(d, &c, sizeof(r)) == -1) return 0;
/* save type */
if (write(d, &st, 1) == -1) return 0;
/* data */
/* we have to collect the rows first, because Octave stores matrices in
column major order */
for (i = 0; i < r; i++)
if (iscons(x, &hd, &tl)) {
rows[i] = hd;
x = tl;
} else
return 0; /* shouldn't happen */
if (!isnil(x)) return 0; /* shouldn't happen */
for (j = 0; j < c; j++)
for (i = 0; i < r; i++)
if (iscons(rows[i], &hd, &tl)) {
if (isscalar(hd, &cplx1, &re, &im)) {
if (write(d, &re, sizeof(re)) == -1) return 0;
if (cplx && write(d, &im, sizeof(im)) == -1) return 0;
} else /* shouldn't happen */
return 0;
rows[i] = tl;
}
for (i = 0; i < r; i++)
if (!isnil(rows[i])) return 0; /* shouldn't happen */
return 1;
}
FUNCTION(octave,octave_set,argc,argv)
{
char *s, magic[magic_len+1];
start_octave();
if (argc == 2 && isstr(argv[0], &s)) {
FILE *fp;
char *t = tmpnam(NULL);
const char *cmd_template = "load -force -binary \"%s\"; unlink \"%s\";";
char *c = (char*)alloca(strlen(cmd_template)+2*strlen(t)+1);
if (!t || !c) return __FAIL;
sprintf(c, cmd_template, t, t);
sprintf(magic, "Octave-1-%c", endian);
if ((fp = fopen(t, "wb"))) {
int cplx, rows, cols;
double re, im;
if (ismatrix(argv[1], &cplx, &rows, &cols)) {
if (!writematrix(fileno(fp), magic, s, cplx, argv[1], rows, cols))
goto errexit;
} else if (isvector(argv[1], &cplx, &cols)) {
if (!writevector(fileno(fp), magic, s, cplx, argv[1], cols))
goto errexit;
} else if (isscalar(argv[1], &cplx, &re, &im)) {
if (!writescalar(fileno(fp), magic, s, cplx, re, im))
goto errexit;
} else
goto errexit;
if (ferror(fp))
goto errexit;
else if (fclose(fp))
goto errexit2;
if (send_octave(c)) return mkvoid;
errexit:
fclose(fp);
errexit2:
unlink(t);
}
return __FAIL;
} else
return __FAIL;
}
/* make sure octave can terminate in a decent manner */
FINI(octave)
{
stop_octave();
}
syntax highlighted by Code2HTML, v. 0.9.1