/*
     libscheme	
     Copyright (C) 1994 Brent Benson

     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 "scheme.h"
#include <string.h>

/* globals */
Scheme_Object *scheme_true;
Scheme_Object *scheme_false;
Scheme_Object *scheme_true_type;
Scheme_Object *scheme_false_type;

/* locals */
static Scheme_Object *scheme_make_true (void);
static Scheme_Object *scheme_make_false (void);
static Scheme_Object *not_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *boolean_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *eq_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]);

static int list_equal (Scheme_Object *lst1, Scheme_Object *lst2);
static int vector_equal (Scheme_Object *vec1, Scheme_Object *vec2);

void
scheme_init_bool (Scheme_Env *env)
{
  scheme_true_type = scheme_make_type ("<true>");
  scheme_false_type = scheme_make_type ("<false>");
  scheme_add_global ("<true>", scheme_true_type, env);
  scheme_add_global ("<false>", scheme_false_type, env);
  scheme_true = scheme_make_true ();
  scheme_false = scheme_make_false ();
  scheme_add_global ("not", scheme_make_prim (not_prim), env);
  scheme_add_global ("boolean?", scheme_make_prim (boolean_p_prim), env);
  scheme_add_global ("eq?", scheme_make_prim (eq_prim), env);
  scheme_add_global ("eqv?", scheme_make_prim (eqv_prim), env);
  scheme_add_global ("equal?", scheme_make_prim (equal_prim), env);
}

static Scheme_Object *
scheme_make_true (void)
{
  Scheme_Object *true;

  true = scheme_alloc_object ();
  SCHEME_TYPE (true) = scheme_true_type;
  return (true);
}

static Scheme_Object *
scheme_make_false (void)
{
  Scheme_Object *false;

  false = scheme_alloc_object ();
  SCHEME_TYPE (false) = scheme_false_type;
  return (false);
}

static Scheme_Object *
not_prim (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT (argc == 1, "not: wrong number of args");
  if (argv[0] == scheme_false)
    {
      return (scheme_true);
    }
  else
    {
      return (scheme_false);
    }
}

static Scheme_Object *
boolean_p_prim (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 1), "boolean?: wrong number of args");
  if ((argv[0] == scheme_false) || (argv[0] == scheme_true))
    {
      return (scheme_true);
    }
  else
    {
      return (scheme_false);
    }
}

static Scheme_Object *
eq_prim (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 2), "eq?: wrong number of args");
  if (argv[0] == argv[1])
    {
      return (scheme_true);
    }
  else
    {
      return (scheme_false);
    }
}

static Scheme_Object *
eqv_prim (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc==2), "eqv?: wrong number of args");
  if (scheme_eqv (argv[0], argv[1]))
    {
      return (scheme_true);
    }
  else
    {
      return (scheme_false);
    }
}

static Scheme_Object *
equal_prim (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 2), "equal?: wrong number of args");
  if (scheme_equal (argv[0], argv[1]))
    {
      return (scheme_true);
    }
  else
    {
      return (scheme_false);
    }
}

int 
scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2)
{
  return (obj1 == obj2);
}

int
scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2)
{
  if (obj1 == obj2)
    {
      return 1;
    }
  else if (SCHEME_TYPE(obj1) != SCHEME_TYPE(obj2))
    {
      return 0;
    }
  else if (SCHEME_TYPE(obj1) == scheme_integer_type &&
	   SCHEME_INT_VAL(obj1) == SCHEME_INT_VAL(obj2))
    {
      return 1;
    }
  else if (SCHEME_TYPE(obj1)== scheme_double_type &&
	   SCHEME_DBL_VAL(obj1) == SCHEME_DBL_VAL(obj2))
    {
      return 1;
    }
  else if (SCHEME_TYPE(obj1) == scheme_char_type &&
	   SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2))
    {
      return 1;
    }
  else if (SCHEME_SYMBOLP(obj1))
    {
      if (strcmp (SCHEME_STR_VAL(obj1), SCHEME_STR_VAL(obj2)) == 0)
	return 1;
      else
	return 0;
    }
  else
    {
      return 0;
    }
}

int
scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
{
  if (scheme_eqv (obj1, obj2))
    {
      return 1;
    }
  else if (SCHEME_TYPE(obj1) != SCHEME_TYPE(obj2))
    {
      return 0;
    }
  else if (SCHEME_TYPE(obj1) == scheme_pair_type &&
	   list_equal(obj1, obj2))
    {
      return 1;
    }
  else if (SCHEME_TYPE(obj1) == scheme_vector_type &&
	   vector_equal(obj1, obj2))
    {
      return 1;
    }
  else if (SCHEME_TYPE(obj1) == scheme_string_type &&
	   (strcmp(SCHEME_STR_VAL(obj1), SCHEME_STR_VAL(obj2)) == 0))
    {
      return 1;
    }
  else 
    {
      return 0;
    }
}

static int
list_equal (Scheme_Object *lst1, Scheme_Object *lst2)
{
  if ((lst1 == scheme_null) && (lst2 == scheme_null))
    {
      return 1;
    }
  else
    {
      return (scheme_equal (SCHEME_CAR (lst1), SCHEME_CAR (lst2)) &&
	      scheme_equal (SCHEME_CDR (lst1), SCHEME_CDR (lst2)));
    }
}

static int
vector_equal (Scheme_Object *vec1, Scheme_Object *vec2)
{
  int i;

  for ( i=0 ; i<SCHEME_VEC_SIZE(vec1) ; ++i )
    {
      if (! scheme_equal (SCHEME_VEC_ELS(vec1)[i], SCHEME_VEC_ELS(vec2)[i]))
	{
	  return 0;
	}
    }
  return 1;
}



