/* libq.c: C interface library */

/*  Q eQuational Programming System
    Copyright (c) 1991-2001 by Albert Graef
    <ag@muwiinfa.geschichte.uni-mainz.de, Dr.Graef@t-online.de>

    This program 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 1, or (at your option)
    any later version.

    This program 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.

*/

#include <stdarg.h>

/* We do _not_ include gmp.h here to make this module self-contained. This
   allows to interface to C modules compiled with non-gnu compilers, for which
   the gmp library may not be available. However, expr.h needs the definition
   of mpz_t, hence we provide a dummy declaration here. */

typedef struct { int a, s; void* d; } mpz_t[1];

#if defined (HAVE_CONFIG_H)
#  include "config.h"
#else
#  ifdef __MINGW32__
#    include "mingw.h"
#  endif
#endif

#include "opcodes.h"
#include "expr.h"

#define __DLL_BUILD 1
#if defined _WIN32
#define __DLLIMPORT __declspec(dllexport)
#define __DLLEXPORT __declspec(dllimport)
#else
#define __DLLIMPORT
#define __DLLEXPORT extern
#endif

#include "libq.h"

#ifdef DMALLOC
#include <dmalloc.h>
#endif

/* Memory allocation routines provided for Mingw/MSVC compatibility under
   Windows (see libq.h). */

__DLLIMPORT void *libq_malloc(size_t size)
{
  return malloc(size);
}

__DLLIMPORT void *libq_realloc(void *p, size_t size)
{
  return realloc(p, size);
}

__DLLIMPORT void *libq_calloc(size_t num, size_t size)
{
  return calloc(num, size);
}

__DLLIMPORT void libq_free(void *p)
{
  free(p);
}

typedef expr (*intp_expr_fun)();
typedef int (*intp_int_fun)();
typedef void (*intp_void_fun)();

static intp_expr_fun __qintp_intexpr;
static intp_expr_fun __qintp_uintexpr;
static intp_expr_fun __qintp_mpzexpr;
static intp_expr_fun __qintp_mpz_floatexpr;
static intp_expr_fun __qintp_floatexpr;
static intp_expr_fun __qintp_strexpr;
static intp_expr_fun __qintp_fileexpr;
static intp_expr_fun __qintp_pipeexpr;
static intp_expr_fun __qintp_funexpr;
static intp_expr_fun __qintp_usrexpr;
static intp_expr_fun __qintp_consexpr;
static intp_expr_fun __qintp_tupleexpr;

static intp_int_fun __qintp_getint;
static intp_int_fun __qintp_getuint;
static intp_int_fun __qintp_getmpz;
static intp_int_fun __qintp_getmpz_float;

static intp_expr_fun __qintp_eval;

static intp_void_fun __qintp_free;

static intp_int_fun __qintp_issym;
static intp_int_fun __qintp_istype;
static intp_int_fun __qintp_isusrtype;
static intp_int_fun __qintp_sym_lookup;
static intp_int_fun __qintp_type_lookup;

static intp_int_fun __qintp_init_thread;
static intp_void_fun __qintp_exit_thread;
static intp_void_fun __qintp_fini_thread;
static intp_int_fun __qintp_this_thread;
static intp_int_fun __qintp_have_lock;
static intp_void_fun __qintp_release_lock;
static intp_void_fun __qintp_acquire_lock;
static intp_void_fun __qintp_acquire_tty;
static intp_void_fun __qintp_release_tty;
static intp_void_fun __qintp_thread_atfork;

static intp_void_fun __qintp_error;

/* Predefined function and type symbols. */

__DLLIMPORT const int truesym = TRUEOP, falsesym = FALSEOP, nilsym = NILOP,
  voidsym = VOIDOP;
__DLLIMPORT const int inttype = INTTYPE, floattype = FLOATTYPE,
  booltype =BOOLTYPE, strtype = STRTYPE, filetype = FILETYPE,
  listtype = LISTTYPE, tupletype = TUPLETYPE;

/* Expression construction. */

__DLLIMPORT expr mkint(long i)
{
  return __qintp_intexpr(i);
}

__DLLIMPORT expr mkuint(unsigned long i)
{
  return __qintp_uintexpr(i);
}

__DLLIMPORT expr mkmpz(void *z)
{
  return __qintp_mpzexpr(z);
}

__DLLIMPORT expr mkmpz_float(double f)
{
  return __qintp_mpz_floatexpr(f);
}

__DLLIMPORT expr mkfloat(double f)
{
  return __qintp_floatexpr(f);
}

__DLLIMPORT expr mkstr(char *s)
{
  return s?__qintp_strexpr(s):NULL;
}

__DLLIMPORT expr mkfile(FILE *fp)
{
  return fp?__qintp_fileexpr(fp):NULL;
}

__DLLIMPORT expr mkpipe(FILE *fp)
{
  return fp?__qintp_pipeexpr(fp):NULL;
}


__DLLIMPORT expr mksym(int sym)
{
  if (__qintp_issym(sym))
    return __qintp_funexpr(sym);
  else
    return NULL;
}

__DLLIMPORT expr mkbool(int flag)
{
  if (flag)
    return mktrue;
  else
    return mkfalse;
}

__DLLIMPORT expr mkobj(int type, void *ptr)
{
  if (__qintp_isusrtype(type))
    return __qintp_usrexpr(type, ptr);
  else
    return NULL;
}


__DLLIMPORT expr mkapp(expr fun, expr arg)
{
  expr x = (fun&&arg)?__qintp_consexpr(APPOP, fun, arg):NULL;
  if (!x) { dispose(fun); dispose(arg); }
  return x;
}

__DLLIMPORT expr mkcons(expr hd, expr tl)
{
  expr x = (hd&&tl)?__qintp_consexpr(CONSOP, hd, tl):NULL;
  if (!x) { dispose(hd); dispose(tl); }
  return x;
}

__DLLIMPORT expr mkcont(expr hd, expr tl)
{
  expr x = (hd&&tl)?__qintp_consexpr(PAIROP, hd, tl):NULL;
  if (!x) { dispose(hd); dispose(tl); }
  return x;
}


__DLLIMPORT expr mklistl(int nelems, ...)
{
  if (nelems <= 0)
    return mknil;
  else {
    expr *elems = malloc(nelems*sizeof(expr));
    if (elems) {
      int i;
      va_list ap;
      va_start(ap, nelems);
      for (i = 0; i < nelems; i++)
	elems[i] = va_arg(ap, expr);
      va_end(ap);
      return mklistv(nelems, elems);
    } else
      return NULL;
  }
}

__DLLIMPORT expr mklistv(int nelems, expr *elems)
{
  if (nelems < 0) nelems = 0;
  if (nelems > 0 && !elems)
    return NULL;
  else {
    int i;
    expr x = mknil;
    for (i = nelems-1; x && i >= 0; i--) {
      expr y = mkcons(elems[i], x);
      x = y;
      if (!x) {
	int j;
	for (j = 0; j < i; j++) dispose(elems[j]);
	break;
      }
    }
    if (elems) free(elems);
    return x;
  }
}


__DLLIMPORT expr mktuplel(int nelems, ...)
{
  if (nelems <= 0)
    return mkvoid;
  else {
    expr *elems = malloc(nelems*sizeof(expr));
    if (elems) {
      int i;
      va_list ap;
      va_start(ap, nelems);
      for (i = 0; i < nelems; i++)
	elems[i] = va_arg(ap, expr);
      va_end(ap);
      return mktuplev(nelems, elems);
    } else
      return NULL;
  }
}

__DLLIMPORT expr mktuplev(int nelems, expr *elems)
{
  if (nelems < 0) nelems = 0;
  if (nelems > 0 && !elems)
    return NULL;
  else if (nelems > 0) {
    int i, chk = 1;
    for (i = 0; i < nelems; i++)
      if (!elems[i]) {
	chk = 0;
	break;
      }
    if (!chk) {
      for (i = 0; i < nelems; i++)
	dispose(elems[i]);
      free(elems);
      return NULL;
    } else {
      for (i = 0; i < nelems; i++)
	((EXPR*)elems[i])->refc++;
      return __qintp_tupleexpr(nelems, elems);
    }
  } else
    return mkvoid;
}


/* Type checking and unboxing. */

__DLLIMPORT int exprsym(const expr x)
{
  if (((EXPR*)x)->fno >= BINARY)
    return ((EXPR*)x)->fno;
  else
    return 0;
}

__DLLIMPORT int exprtype(const expr x)
{
  return !((EXPR*)x)->argc?((EXPR*)x)->type:0;
}


__DLLIMPORT int isint(const expr x, long *i)
{
  return __qintp_getint(x, i);
}

__DLLIMPORT int isuint(const expr x, unsigned long *i)
{
  return __qintp_getuint(x, i);
}

__DLLIMPORT int ismpz(const expr x, void *z)
{
  return __qintp_getmpz(x, z);
}

__DLLIMPORT int ismpz_float(const expr x, double *f)
{
  return __qintp_getmpz_float(x, f);
}

__DLLIMPORT int isfloat(const expr x, double *f)
{
  if (((EXPR*)x)->fno == FLOATVALOP) {
    *f = ((EXPR*)x)->data.f;
    return 1;
  } else
    return 0;
}

__DLLIMPORT int isstr(const expr x, char **s)
{
  if (((EXPR*)x)->fno == STRVALOP) {
    *s = ((EXPR*)x)->data.s;
    return 1;
  } else
    return 0;
}

__DLLIMPORT int isfile(const expr x, FILE **fp)
{
  if (((EXPR*)x)->fno == FILEVALOP) {
    *fp = ((EXPR*)x)->data.fp;
    return 1;
  } else
    return 0;
}


__DLLIMPORT int issym(const expr x, int sym)
{
   return sym >= BINARY && ((EXPR*)x)->fno == sym;
}

__DLLIMPORT int isbool(const expr x, int *flag)
{
  if (istrue(x)) {
    *flag = 1;
    return 1;
  } else if (isfalse(x)) {
    *flag = 0;
    return 1;
  } else
    return 0;
}


__DLLIMPORT int isobj(const expr x, int type, void **ptr)
{
  if (((EXPR*)x)->fno == USRVALOP && ((EXPR*)x)->type == type) {
    *ptr = ((EXPR*)x)->data.vp;
    return 1;
  } else
    return 0;
}

__DLLIMPORT int isapp(const expr x, expr *fun, expr *arg)
{
  if (((EXPR*)x)->fno == APPOP) {
    *fun = ((EXPR*)x)->data.args.x1;
    *arg = ((EXPR*)x)->data.args.x2;
    return 1;
  } else
    return 0;
}

__DLLIMPORT int iscons(const expr x, expr *hd, expr *tl)
{
  if (((EXPR*)x)->fno == CONSOP) {
    *hd = ((EXPR*)x)->data.args.x1;
    *tl = ((EXPR*)x)->data.args.x2;
    return 1;
  } else
    return 0;
}

__DLLIMPORT int iscont(const expr x, expr *hd, expr *tl)
{
  if (((EXPR*)x)->fno == PAIROP) {
    *hd = ((EXPR*)x)->data.args.x1;
    *tl = ((EXPR*)x)->data.args.x2;
    return 1;
  } else
    return 0;
}


__DLLIMPORT int istuple(const expr x, int *nelems, expr **elems)
{
  if (((EXPR*)x)->fno == VECTOP) {
    *nelems = ((EXPR*)x)->data.vect.n;
    *elems = (expr*)((EXPR*)x)->data.vect.xv;
    return 1;
  } else
    return 0;
}


/* Expression evaluation. */

__DLLIMPORT expr eval(const expr x)
{
  if (x) {
    expr ret = __qintp_eval(x);
    if (x != ret) dispose(x);
    return ret;
  } else
    return NULL;
}

/* Garbage collection. */

__DLLIMPORT void dispose(expr x)
{
  if (x && ((EXPR*)x)->refc == 0) {
    ((EXPR*)x)->refc = 1;
    __qintp_free(x);
  }
}

/* Multithreading. */

__DLLIMPORT int init_thread(void)
{
  return __qintp_init_thread();
}

__DLLIMPORT void exit_thread(int id)
{
  if (id >= 0)
    __qintp_exit_thread(id);
}

__DLLIMPORT void fini_thread(int id)
{
  if (id >= 0)
    __qintp_fini_thread(id);
}

__DLLIMPORT int this_thread(void)
{
  return __qintp_this_thread();
}

__DLLIMPORT int have_lock(void)
{
  return __qintp_have_lock();
}

__DLLIMPORT void release_lock(void)
{
  __qintp_release_lock();
}

__DLLIMPORT void acquire_lock(void)
{
  __qintp_acquire_lock();
}

__DLLIMPORT void acquire_tty(void)
{
  __qintp_acquire_tty();
}

__DLLIMPORT void release_tty(void)
{
  __qintp_release_tty();
}

__DLLIMPORT expr newref(expr x)
{
  if (x) ((EXPR*)x)->refc++;
  return x;
}

__DLLIMPORT expr unref(expr x)
{
  if (x) ((EXPR*)x)->refc--;
  return x;
}

__DLLIMPORT void freeref(expr x)
{
  if (x && --(((EXPR*)x)->refc) == 0)
    dispose(x);
}

/* Internals. */

/* initialization (executed by the interpreter); set up interface to the
   interpreter */

__DLLIMPORT int __libq_init
(

 /* expression construction */
 intp_expr_fun qintp_intexpr,
 intp_expr_fun qintp_uintexpr,
 intp_expr_fun qintp_mpzexpr,
 intp_expr_fun qintp_mpz_floatexpr,
 intp_expr_fun qintp_floatexpr,
 intp_expr_fun qintp_strexpr,
 intp_expr_fun qintp_fileexpr,
 intp_expr_fun qintp_pipeexpr,
 intp_expr_fun qintp_funexpr,
 intp_expr_fun qintp_usrexpr,
 intp_expr_fun qintp_consexpr,
 intp_expr_fun qintp_tupleexpr,

 /* expression lookup */
 intp_int_fun qintp_getint,
 intp_int_fun qintp_getuint,
 intp_int_fun qintp_getmpz,
 intp_int_fun qintp_getmpz_float,

 /* expression evaluation */
 intp_expr_fun qintp_eval,

 /* garbage collection */
 intp_void_fun qintp_free,

 /* symbol table lookup */
 intp_int_fun qintp_issym,
 intp_int_fun qintp_istype,
 intp_int_fun qintp_isusrtype,
 intp_int_fun qintp_sym_lookup,
 intp_int_fun qintp_type_lookup,

 /* multithreading */
 intp_int_fun qintp_init_thread,
 intp_void_fun qintp_exit_thread,
 intp_void_fun qintp_fini_thread,
 intp_int_fun qintp_this_thread,
 intp_int_fun qintp_have_lock,
 intp_void_fun qintp_release_lock,
 intp_void_fun qintp_acquire_lock,
 intp_void_fun qintp_acquire_tty,
 intp_void_fun qintp_release_tty,
 intp_void_fun qintp_thread_atfork,

 /* error status */
 intp_void_fun qintp_error
)
{
  __qintp_intexpr = qintp_intexpr;
  __qintp_uintexpr = qintp_uintexpr;
  __qintp_mpzexpr = qintp_mpzexpr;
  __qintp_mpz_floatexpr = qintp_mpz_floatexpr;
  __qintp_floatexpr = qintp_floatexpr;
  __qintp_strexpr = qintp_strexpr;
  __qintp_fileexpr = qintp_fileexpr;
  __qintp_pipeexpr = qintp_pipeexpr;
  __qintp_funexpr = qintp_funexpr;
  __qintp_usrexpr = qintp_usrexpr;
  __qintp_consexpr = qintp_consexpr;
  __qintp_tupleexpr = qintp_tupleexpr;

  __qintp_getint = qintp_getint;
  __qintp_getuint = qintp_getuint;
  __qintp_getmpz = qintp_getmpz;
  __qintp_getmpz_float = qintp_getmpz_float;

  __qintp_eval = qintp_eval;

  __qintp_free = qintp_free;

  __qintp_issym = qintp_issym;
  __qintp_istype = qintp_istype;
  __qintp_isusrtype = qintp_isusrtype;
  __qintp_sym_lookup = qintp_sym_lookup;
  __qintp_type_lookup = qintp_type_lookup;

  __qintp_init_thread = qintp_init_thread;
  __qintp_exit_thread = qintp_exit_thread;
  __qintp_fini_thread = qintp_fini_thread;
  __qintp_this_thread = qintp_this_thread;
  __qintp_have_lock = qintp_have_lock;
  __qintp_release_lock = qintp_release_lock;
  __qintp_acquire_lock = qintp_acquire_lock;
  __qintp_acquire_tty = qintp_acquire_tty;
  __qintp_release_tty = qintp_release_tty;
  __qintp_thread_atfork = qintp_thread_atfork;

  __qintp_error = qintp_error;

  return 1;
}

/* helper functions */

__DLLIMPORT expr __mkerror(void)
{
  __qintp_error();
  return NULL;
}

__DLLIMPORT int __getsym(const char *name, int modno)
{
  return __qintp_sym_lookup(name, modno);
}

__DLLIMPORT int __gettype(const char *name, int modno)
{
  return __qintp_type_lookup(name, modno);
}

__DLLIMPORT void __thread_atfork(void (*prepare)(void), void (*parent)(void),
				 void (*child)(void), int modno)
{
  __qintp_thread_atfork(prepare, parent, child, modno);
}