/* libsizzle/vector.c - vector functions
 
  Copyright (C) 1999, 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This 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.
  
  This software 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 package; see the file COPYING.  If not, write to
  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  Boston, MA 02111-1307, USA.  */

#if HAVE_CONFIG_H
# include <config.h>
#endif 

#include <assert.h>
#include <stdlib.h>

#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include "alloc.h"
#include "node.h"
#include "validate.h"
#include "capi.h"
#include "port.h"
#include "list.h"
#include "vector.h"

/* Define this if you want the vector module to cache the vector data
   areas used for creating local environments.  This speeds up
   environment creation a bit.  Undefine to check out the performance
   difference. */
/*  #define CACHE_ENVIRONMENTS 1 */

/* This holds the tag used for vector objects.  */
zzz_object_t zzz_tagged_type_vector;

/* This holds the tag used for hash table objects.  */
zzz_object_t zzz_tagged_type_hashtable;

/*:doc
  vector?
  (vector? obj) => boolean
  Return @code{#t}, if @var{obj} is a vector, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "vector?"
static result_t
vector_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  if (vector_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  make-vector
  (make-vector len [fill]) => vector
  Create a vector capable of holding @var{len} elements and initializes the
  vector fields to @var{fill}.  If @var{fill} is omitted, the contents of
  the vector is undefined.
  doc:*/
#define FUNC_NAME "make-vector"
static result_t
make_vector_func (zzz_scm_t env, zzz_scm_t k, zzz_scm_t fill,
		  zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int len;

  CHECK_TYPE (1, integer_p (k), zzz_integer_type_name);
  /* @var{fill} is undefined if not specified, and that is what we
     want.  */
  len = integer_val (k);
  if (len < 0)
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("length in call to `"), -1), 
	  zzz_make_string (s_func_name, -1), 
	  zzz_make_string (_("' must be greater than zero"), -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_vector (len);
  while (--len >= 0)
    zzz_vector_put (*result, len, fill);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  vector
  (vector obj0 ...) => vector
  Create a vector holding all the @var{obj}s passed as arguments.
  doc:*/
#define FUNC_NAME "vector"
static result_t
vector_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  zzz_scm_t temp;
  zzz_scm_t res = NULL;
  int len;

  /* Param is guaranteed to be a proper list when we get here.  */
  len = zzz_list_length (param);
  res = zzz_make_vector (len);
  len = 0;
  temp = param;
  while (cons_p (temp))
    {
      zzz_vector_put (res, len, car (temp));
      temp = cdr (temp);
      len++;
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  vector-length
  (vector-length vec) => integer
  Return the number of elements the vector @var{vec} can hold.
  doc:*/
#define FUNC_NAME "vector-length"
static result_t
vector_length_func (zzz_scm_t env, zzz_scm_t vec, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, vector_p (vec), zzz_vector_type_name);
  *result = zzz_make_integer (vector_len (vec));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  vector-ref
  (vector-ref vec n) => object
  Return the element stored at index @var{n} in the vector @var{vec}.  The
  index @var{n} is zero-based.
  doc:*/
#define FUNC_NAME "vector-ref"
static result_t
vector_ref_func (zzz_scm_t env, zzz_scm_t vec, zzz_scm_t k, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  unsigned long index;

  CHECK_TYPE (1, vector_p (vec), zzz_vector_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  index = integer_val (k);
  if (index >= vector_len (vec))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("index out of range in call to `"), -1),
	  zzz_make_string (s_func_name, -1),
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  *result = zzz_vector_get (vec, index);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  vector-set!
  (vector-set! vec n obj) => *undefined*
  Store the object @var{obj} a index @var{n} into the vector @var{vec}.  The
  index @var{n} is zerobased.
  doc:*/
#define FUNC_NAME "vector-set!"
static result_t
vector_set_x_func (zzz_scm_t env, zzz_scm_t vec, zzz_scm_t k, zzz_scm_t obj,
		   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  unsigned long index;

  CHECK_TYPE (1, vector_p (vec), zzz_vector_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  if (ro_vector_p (vec))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("read-only vector passed to `"), -1),
	  zzz_make_string (s_func_name, -1), 
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  index = integer_val (k);
  if (index >= vector_len (vec))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("index out of range in call to `"), -1),
	  zzz_make_string (FUNC_NAME, -1),
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  zzz_vector_put (vec, index, obj);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  vector->list
  (vector->list vec) => list
  Return a list containing the elements of the vector @var{vec}.
  doc:*/
#define FUNC_NAME "vector->list"
static result_t
vector_to_list_func (zzz_scm_t env, zzz_scm_t vec, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res;
  unsigned long len;

  CHECK_TYPE (1, vector_p (vec), zzz_vector_type_name);
  len = vector_len (vec);
  res = NULL;
  while (len-- > 0)
    res = zzz_cons (zzz_vector_get (vec, len), res);
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  list->vector
  (list->vector list) => vector
  Return a vector containing the elements of the list @var{list}.
  doc:*/
#define FUNC_NAME "list->vector"
static result_t
list_to_vector_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t vec = NULL;
  int len = 0;

  CHECK_TYPE (1, zzz_list_length (list) >= 0, zzz_proper_list_type_name);
  /* Param is guaranteed to be a proper list when we get here.  */
  len = zzz_list_length (list);
  vec = zzz_make_vector (len);
  len = 0;
  while (cons_p (list))
    {
      zzz_vector_put (vec, len, car (list));
      len++;
      list = cdr (list);
    }
  *result = vec;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  vector-fill!
  (vector-fill! vec obj) => *undefined*
  Store @var{obj} in all elements of the vector @var{vec}, overwriting the
  old contents of @var{vec}.
  doc:*/
#define FUNC_NAME "vector-fill!"
static result_t
vector_fill_x_func (zzz_scm_t env, zzz_scm_t vec, zzz_scm_t fill,
		    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  unsigned long len;

  CHECK_TYPE (1, vector_p (vec), zzz_vector_type_name);
  if (ro_vector_p (vec))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("read-only vector passed to `"), -1),
	  zzz_make_string (s_func_name, -1), 
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  len = vector_len (vec);
  while (len-- > 0)
    zzz_vector_put (vec, len, fill);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* The following two functions for accessing vector elements are only
   compiled in if their macro replacements are commented out in
   vector.h.  They are available as C functions for debugging
   purposes.  */
#ifndef zzz_vector_put
void
zzz_vector_put (zzz_scm_t vector, unsigned long index, zzz_scm_t elem)
{
  assert (vector_p (vector));
  assert (index < vector_len (vector));
  vector_val (vector)[index] = elem;
}
#endif /* !defined (zzz_vector_put) */

#ifndef zzz_vector_get
zzz_scm_t
zzz_vector_get (zzz_scm_t vector, unsigned long index)
{
  assert (vector_p (vector));
  assert (index < vector_len (vector));
  return vector_val (vector)[index];
}
#endif /* !defined (zzz_vector_get) */

/* Constructor function for vector objects.  Expects the desired
   vector len as a long value in DATA0.  Returns TAGGED.  */
static void *
vector_constructor (zzz_tagged_t tagged, void * data0,
		    void * data1, void * data2)
{
  unsigned long len = (zzz_object_t) data0;
  zzz_scm_t * vec;
  unsigned long x;

  vec = zzz_malloc (sizeof (zzz_scm_t) * len);
  for (x = 0; x < len; x++)
    vec[x] = NULL;
  tagged->fill[1] = (zzz_object_t) vec;
  tagged->fill[2] = (zzz_object_t) len;
  return tagged;
}

/* Print function for vector objects.  Prints the vector TAGGED on
   port PORT, using the print state STATE.  */
static void
vector_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  zzz_scm_t * vec = vector_val (tagged);
  unsigned long len = vector_len (tagged);
  unsigned long x;

  zzz_port_putc ('#', port, &result);
  zzz_port_putc ('(', port, &result);
  for (x = 0; x < len; x++)
    {
      zzz_port_print (port, vec[x], state, &result);
      if (x < len - 1)
	zzz_port_putc (' ', port, &result);
    }
  zzz_port_putc (')', port, &result);
}

/* Free function for vectors.  Vectors used for environments are kept
   in a free list in order to speed up environment creation.  */
static void
vector_free (zzz_tagged_t tagged)
{
  unsigned long len =  vector_len (tagged);

  zzz_free (vector_val (tagged), sizeof (zzz_scm_t) * len);
}

/* Mark function for vector objects.  The vector object TAGGED is
   marked by marking all vector elements.  */
static void
vector_mark (zzz_tagged_t tagged)
{
  zzz_scm_t * vec = vector_val (tagged);
  unsigned long len = vector_len (tagged);
  unsigned long x;

  for (x = 0; x < len; x++)
    zzz_mark_cell (vec[x]);
}

/* Equality predicate for vectors.  Returns 1 if the two vector
   objects TAGGED0 and TAGGED1 are equal.  Two vectors are equal if
   they have the same length and their corresponding elements are
   `equal?'.  */
static int
vector_equal (zzz_tagged_t tagged0, zzz_tagged_t tagged1)
{
  zzz_scm_t * vec1   = vector_val (tagged0);
  unsigned long len1 = vector_len (tagged0);
  zzz_scm_t * vec2   = vector_val (tagged1);
  unsigned long len2 = vector_len (tagged1);
  unsigned long x;

  if (len1 != len2)
    return 0;
  for (x = 0; x < len1; x++)
    {
      if (!zzz_equal (vec1[x], vec2[x]))
	return 0;
    }
  return 1;
}

/* Print function for hash table objects.  Prints the vector @var{tagged} on
   port @var{port}, using the print state @var{state}.  */
static void
hashtable_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  zzz_scm_t * vec = vector_val (tagged);
  unsigned long len = vector_len (tagged);
  unsigned long x;
  zzz_scm_t dummy;
  int print_separator = 0;

  zzz_port_putc ('#', port, &result);
  zzz_port_putc ('{', port, &result);
  for (x = 0; x < len; x++)
    {
      dummy = vec[x];
      while (cons_p (dummy))
	{
	  if (cons_p (car (dummy)))
	    {
	      if (print_separator)
		zzz_port_putc (' ', port, &result);
	      zzz_port_print (port, car (car (dummy)), state, &result);
	      zzz_port_puts (port, " => ", 4, &result);
	      zzz_port_print (port, cdr (car (dummy)), state, &result);
	      print_separator = 1;
	    }
	  dummy = cdr (dummy);
	}
    }
  zzz_port_putc ('}', port, &result);
}

zzz_scm_t
zzz_make_vector (int len)
{
  return zzz_create_tagged_cell (zzz_tagged_type_vector,
				 (void *) ((zzz_object_t) len), NULL, NULL);
}

zzz_scm_t
zzz_make_ro_vector (int len)
{
  return zzz_create_tagged_cell (zzz_tagged_type_vector | tagged_info_ro,
				 (void *) ((zzz_object_t) len), NULL, NULL);
}

zzz_scm_t
zzz_make_hashtable (int len)
{
  return zzz_create_tagged_cell (zzz_tagged_type_hashtable,
				 (void *) ((zzz_object_t) len), NULL, NULL);
}

zzz_scm_t
zzz_make_ro_hashtable (int len)
{
  return zzz_create_tagged_cell (zzz_tagged_type_hashtable | tagged_info_ro,
				 (void *) ((zzz_object_t) len), NULL, NULL);
}

result_t
zzz_init_vector_type (void)
{
  zzz_tagged_type_vector =
    zzz_define_tagged_type (vector_constructor, vector_print, vector_free,
			    vector_mark, vector_equal);
  zzz_tagged_type_hashtable =
    zzz_define_tagged_type (vector_constructor, hashtable_print, vector_free,
			    vector_mark, vector_equal);
  return RESULT_SUCCESS;
}

result_t
zzz_init_vector (void)
{
  zzz_define_function ("vector?", (zzz_prim_t) vector_p_func, argv_1_0_0);
  zzz_define_function ("make-vector", (zzz_prim_t) make_vector_func,
		       argv_1_1_0);
  zzz_define_function ("vector-length", (zzz_prim_t) vector_length_func,
		       argv_1_0_0);
  zzz_define_function ("vector", (zzz_prim_t) vector_func, argv_0_0_1);
  zzz_define_function ("vector-ref", (zzz_prim_t) vector_ref_func, argv_2_0_0);
  zzz_define_function ("vector-set!", (zzz_prim_t) vector_set_x_func,
		       argv_3_0_0);
  zzz_define_function ("vector->list", (zzz_prim_t) vector_to_list_func,
		       argv_1_0_0);
  zzz_define_function ("list->vector", (zzz_prim_t) list_to_vector_func,
		       argv_1_0_0);
  zzz_define_function ("vector-fill!", (zzz_prim_t) vector_fill_x_func,
		       argv_2_0_0);
  return RESULT_SUCCESS;
}
