/* 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 <malloc.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();
}