/* libsizzle/box.c - box handling primitive procedures
 
  Copyright (C) 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 

#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 "box.h"

zzz_object_t zzz_tagged_type_box;

zzz_scm_t
zzz_make_box (zzz_scm_t obj)
{
  return zzz_create_tagged_cell (zzz_tagged_type_box, obj, NULL, NULL);
}

/*:doc
  box?
  (box? obj) => boolean
  Return @code{#t} if @var{obj}is a box object.
  doc:*/
#define FUNC_NAME "box?"
static result_t
box_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (box_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  make-box
  (make-box obj) => box
  Create a new box object containing the Scheme object @var{obj}.
  doc:*/
#define FUNC_NAME "make-box"
static result_t
make_box (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  *result = zzz_make_box (obj);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  box-ref
  (box-ref box) => obj
  Return the object contained in the box object @var{box}.
  doc:*/
#define FUNC_NAME "box-ref"
static result_t
box_ref (zzz_scm_t env, zzz_scm_t box, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, box_p (box), zzz_box_type_name);
  *result = box_val (box);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  box-set!
  (box-set! box obj) => *unspecified*
  Store the Scheme object @var{obj} in the box object @var{box}.
  doc:*/
#define FUNC_NAME "box-set!"
static result_t
box_set_x (zzz_scm_t env, zzz_scm_t box, zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, box_p (box), zzz_box_type_name);
  ((zzz_tagged_t) to_ptr (box))->fill[1] = (zzz_object_t) obj;
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Print the box object @var{tagged} to the output port @var{port}.  */
static void
box_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;

  zzz_port_puts (port, "#<box: ", 7, &result);
  zzz_port_print (port, box_val (tagged), state, &result);
  zzz_port_puts (port, ">", 1, &result);
}

result_t
zzz_init_box (void)
{
  /* Define the tagged type for box objects.  */
  zzz_tagged_type_box = zzz_define_tagged_type (zzz_simple_constructor,
						box_print,
						NULL,
						zzz_simple_mark,
						NULL);

  zzz_define_function ("box?", (zzz_prim_t) box_p_func, argv_1_0_0);
  zzz_define_function ("make-box", (zzz_prim_t) make_box, argv_1_0_0);
  zzz_define_function ("box-ref", (zzz_prim_t) box_ref, argv_1_0_0);
  zzz_define_function ("box-set!", (zzz_prim_t) box_set_x, argv_2_0_0);
  return RESULT_SUCCESS;
}
