/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (c)  2010-2011, VU University Amsterdam
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This include file emulates <sicstus.h> for SWI-Prolog.

This  version  was   written   to   get    the   Alpino   parser   suite
(http://www.let.rug.nl/vannoord/alp/Alpino/) to run on SWI-Prolog. It is
by no means complete and intended  as   a  `living document'. So, please
contribute   your   changes.    See     also    library(qpforeign)   and
library(dialect/sicstus).

Most should be(come) fully compatible. Some  issues are hard to emulate.
Please checks the notes for:

	* SP_to_os()
	* SP_from_os()
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#ifndef SICSTUS_H_INCLUDED
#define SICSTUS_H_INCLUDED
#include <SWI-Prolog.h>
#include <assert.h>

typedef term_t SP_term_ref;
typedef atom_t SP_atom;
typedef predicate_t SP_pred_ref;

#define SP_ERROR  -1
#define SP_FAILURE 0
#define SP_SUCCESS 1

#define SP_WHEN_RESTORE 1		/* Note: these are not supported yet */
#define SP_WHEN_SAVE 2

#define SP_TYPE_ATOM     PL_ATOM
#define SP_TYPE_COMPOUND PL_TERM
#define SP_TYPE_FLOAT    PL_FLOAT
#define SP_TYPE_INTEGER  PL_INTEGER
#define SP_TYPE_VARIABLE PL_VARIABLE


		 /*******************************
		 *  READING AND WRITING TERMS	*
		 *******************************/

#define REP_SP PL_cvt_encoding()

#define SP_new_term_ref() PL_new_nil_ref()

#define SP_is_list(t) PL_is_list(t)

#define SP_cons_list(l,h,t) PL_cons_list(l,h,t)

#define SP_atom_from_string(s) PL_new_atom(s)
#define SP_string_from_atom(a) PL_atom_chars(a)

#define SP_put_variable(t) PL_put_variable(t)
#define SP_put_atom(t,a) PL_put_atom(t,a)
#define SP_put_integer(t,i) PL_put_integer(t,i)
#define SP_put_float(t,f) PL_put_float(t,f)
#define SP_put_list(t) PL_put_list(t)
#define SP_put_term(t1,t2) PL_put_term(t1,t2)

#define SP_get_float(t,f) PL_get_float(t,f)
#define SP_get_functor(t,n,a) PL_get_name_arity(t,n,a)
#define SP_get_list(l,h,t) PL_get_list(l,h,t)
#define SP_get_string(t,s) PL_get_chars(t,(char**)(s),CVT_ATOM|REP_SP)
#define SP_get_integer(t,pi) PL_get_long(t, pi)
#define SP_get_arg(i,t,a) PL_get_arg(i,t,a)

#define SP_unify(x,y) PL_unify(x,y)
#define SP_term_type(t) PL_term_type(t)

static __inline int
SP_put_string(term_t t, const char *s)
{ PL_put_variable(t);

  return PL_unify_chars(t, PL_ATOM|REP_SP, (size_t)-1, s);
}


static __inline int
SP_put_list_n_bytes(SP_term_ref list, SP_term_ref tail,
		    size_t len, unsigned char const *buf)
{ term_t t0 = PL_new_term_refs(2);
  int rc = PL_unify_chars(t0, PL_CODE_LIST|PL_DIFF_LIST|REP_ISO_LATIN_1,
			  len, (const char*)buf);

  if ( rc )
  { PL_put_term(list, t0);
    rc = PL_unify(tail, t0+1);
  }

  return rc;
}


static __inline int
SP_put_list_chars(SP_term_ref list, SP_term_ref tail, const char *s)
{ term_t t0 = PL_new_term_refs(2);
  int rc = PL_unify_chars(t0, PL_CODE_LIST|PL_DIFF_LIST|REP_SP,
			  (size_t)-1, s);

  if ( rc )
  { PL_put_term(list, t0);
    rc = PL_unify(tail, t0+1);
  }

  return rc;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Copies into the byte array s the  initial elements of term, which should
hold a list of integers in the range   [0,255],  so that at most n bytes
are used. The number of bytes actually   written is assigned to *w. tail
is set to the remainder of the list. The   array s must have room for at
least n bytes.

TBD: This implementation is a bit slow, but   it should do the trick for
now.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

static __inline int
SP_get_list_n_bytes(SP_term_ref term,
		    SP_term_ref tail,
		    size_t n,
		    size_t *w,
		    unsigned char *s)
{ size_t written = 0;
  term_t head = PL_new_term_ref();

  PL_put_term(tail, term);
  while( written < n && PL_get_list(tail, head, tail) )
  { int i;

    if ( PL_get_integer(head, &i) && i >= 0 && i <= 255 )
    { s[written++] = i;
    } else
    { *w = written;
      return SP_ERROR;			/* Is this ok? */
    }
  }

  *w = written;
  return SP_SUCCESS;
}


static __inline int
SP_get_number_codes(SP_term_ref term, char const **s)
{ char *tmp;

  if ( PL_get_chars(term, &tmp, CVT_NUMBER) )
  { *s = (const char*)tmp;
    return TRUE;
  }

  return FALSE;
}


static __inline int
SP_put_number_codes(SP_term_ref term, char const *s)
{ term_t t = PL_new_term_ref();

  if ( PL_chars_to_term(s, t) &&
       PL_is_number(t) )
  { PL_put_term(term, t);
    return TRUE;
  }

  return FALSE;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
If native is zero, buf  consists  of   the  buf_size  bytes  of the twos
complement representation of the integer. Less  significant bytes are at
lower indices
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

static __inline int
SP_put_integer_bytes(SP_term_ref term,
		     void *buf, size_t buf_size,
		     int native)
{ if ( native )
  { int64_t val;

    switch(buf_size)
    { case 1:
	{ char *p = (char*)buf;
	val = *p;
	break;
      }
      case 2:
	{ short *p = (short*)buf;
	val = *p;
	break;
      }
      case 4:
	{ int *p = (int*)buf;
	val = *p;
	break;
      }
      case 8:
	{ int64_t *p = (int64_t*)buf;
	val = *p;
	break;
      }
    default:
      return FALSE;
    }

    return PL_put_int64(term, val);
  } else					/* see above */
  {
#ifdef __GNU_MP__
    mpz_t mpz;
    int rc;

    mpz_init(mpz);
    mpz_import(mpz,
	       buf_size,			/* COUNT */
	       1,				/* ORDER */
	       1,				/* SIZE */
	       0,				/* ENDIAN (native) */
	       0,				/* NAILS */
	       buf);				/* OP */
    PL_put_variable(term);
    rc = PL_unify_mpz(term, mpz);
    mpz_clear(mpz);

    return rc;
#else
    assert(0);
#endif
  }
}



static __inline int
SP_cons_functor_array(SP_term_ref term, SP_atom name, int arity,
		      SP_term_ref *arg)
{ functor_t f = PL_new_functor(name, arity);
  term_t argv;

  if ( (argv=PL_new_term_refs(arity)) )
  { int i;

    for(i=0; i<arity; i++)
      PL_put_term(argv+i, arg[i]);

    return PL_cons_functor_v(term, f, argv);
  }

  return FALSE;
}



		 /*******************************
		 * RETURN CODES AND EXCEPTIONS	*
		 *******************************/

#define SP_raise_exception(t) do { PL_raise_exception(t); \
				   SP_set_state(SP_ERROR); \
				 } while(0)
#define SP_fail()	      do { SP_set_state(SP_FAILURE); \
				 } while(0)
#define SP_WRAP_INIT() \
	SP_set_state(SP_SUCCESS)
#define SP_WRAP_CHECK_STATE() \
	if ( SP_get_state() != SP_SUCCESS ) \
	  return FALSE


		 /*******************************
		 *	 C CALLING PROLOG	*
		 *******************************/

#define SP_predicate(name,arity,module) PL_predicate(name,arity,module)

static __inline int
SP_query(SP_pred_ref predicate, ...)
{ atom_t name;
  int i, arity;
  module_t module;
  fid_t fid;
  qid_t qid;
  term_t t0;
  va_list args;

  if ( !(fid = PL_open_foreign_frame()) )
    return SP_ERROR;

  PL_predicate_info(predicate, &name, &arity, &module);

  if ( !(t0 = PL_new_term_refs(arity)) )
  { PL_close_foreign_frame(fid);
    return SP_ERROR;
  }

  va_start(args, predicate);
  for(i=0; i<arity; i++)
  { term_t a = va_arg(args, term_t);
    PL_put_term(t0+i, a);
  }
  va_end(args);

  if ( !(qid=PL_open_query(NULL, PL_Q_CATCH_EXCEPTION, predicate, t0)) )
    return SP_ERROR;
  if ( !PL_next_solution(qid) )
  { term_t ex = PL_exception(qid);

    PL_cut_query(qid);
    PL_close_foreign_frame(fid);
    if ( ex )
      return SP_ERROR;
    return SP_FAILURE;
  }
  PL_cut_query(qid);
  PL_close_foreign_frame(fid);

  return SP_SUCCESS;
}


static __inline int
SP_query_cut_fail(SP_pred_ref predicate, ...)
{ atom_t name;
  int i, arity;
  module_t module;
  fid_t fid;
  qid_t qid;
  term_t t0;
  va_list args;

  if ( !(fid = PL_open_foreign_frame()) )
    return SP_ERROR;

  PL_predicate_info(predicate, &name, &arity, &module);

  if ( !(t0 = PL_new_term_refs(arity)) )
  { PL_close_foreign_frame(fid);
    return SP_ERROR;
  }

  va_start(args, predicate);
  for(i=0; i<arity; i++)
  { term_t a = va_arg(args, term_t);
    PL_put_term(t0+i, a);
  }
  va_end(args);

  if ( !(qid=PL_open_query(NULL, PL_Q_CATCH_EXCEPTION, predicate, t0)) )
    return SP_ERROR;
  if ( !PL_next_solution(qid) )
  { term_t ex = PL_exception(qid);

    PL_cut_query(qid);
    if ( ex )
    { PL_close_foreign_frame(fid);
      return SP_ERROR;
    }
    PL_discard_foreign_frame(fid);
    return SP_FAILURE;
  }
  PL_cut_query(qid);
  PL_discard_foreign_frame(fid);

  return SP_SUCCESS;
}


#define SP_malloc(n) PL_malloc(n)
#define SP_realloc(p,n) PL_realloc(p,n)
#define SP_free(p) PL_free(p)


/* These functions perform string-encoding conversion between Prolog and
   the OS-native representation.  This is done using the conversion-flag
   in SWI-Prolog's PL_get_chars() and PL_unify_chars() routines. I'm not
   sure how we should deal with this.
*/

#define SP_to_os(s,c) (s)
#define SP_from_os(s,c) (s)

#endif /*SICSTUS_H_INCLUDED*/
