picrin/extlib/benz/bool.c

273 lines
5.6 KiB
C
Raw Normal View History

2014-08-25 00:38:09 -04:00
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
2016-02-18 10:08:39 -05:00
#include "picrin/object.h"
2014-08-25 00:38:09 -04:00
#if PIC_NAN_BOXING
bool
pic_eq_p(pic_state PIC_UNUSED(*pic), pic_value x, pic_value y)
{
return x == y;
}
bool
pic_eqv_p(pic_state PIC_UNUSED(*pic), pic_value x, pic_value y)
{
return x == y;
}
#else
bool
pic_eq_p(pic_state PIC_UNUSED(*pic), pic_value x, pic_value y)
{
if (pic_type(pic, x) != pic_type(pic, y))
return false;
switch (pic_type(pic, x)) {
case PIC_TYPE_NIL:
return true;
case PIC_TYPE_TRUE: case PIC_TYPE_FALSE:
return pic_type(pic, x) == pic_type(pic, y);
default:
return pic_obj_ptr(x) == pic_obj_ptr(y);
}
}
bool
pic_eqv_p(pic_state PIC_UNUSED(*pic), pic_value x, pic_value y)
{
if (pic_type(pic, x) != pic_type(pic, y))
return false;
switch (pic_type(pic, x)) {
case PIC_TYPE_NIL:
return true;
case PIC_TYPE_TRUE: case PIC_TYPE_FALSE:
return pic_type(pic, x) == pic_type(pic, y);
case PIC_TYPE_FLOAT:
return pic_float(pic, x) == pic_float(pic, y);
case PIC_TYPE_INT:
return pic_int(pic, x) == pic_int(pic, y);
default:
return pic_obj_ptr(x) == pic_obj_ptr(y);
}
}
#endif
2015-06-24 17:44:45 -04:00
KHASH_DECLARE(m, void *, int)
KHASH_DEFINE2(m, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal)
2014-08-25 00:38:09 -04:00
static bool
2015-08-26 06:04:27 -04:00
internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m) *h)
2014-08-25 00:38:09 -04:00
{
pic_value localx = pic_nil_value(pic);
pic_value localy = pic_nil_value(pic);
2015-12-27 21:27:26 -05:00
int cx = 0;
int cy = 0;
2014-08-25 00:38:09 -04:00
if (depth > 10) {
if (depth > 200) {
pic_errorf(pic, "Stack overflow in equal\n");
}
if (pic_pair_p(pic, x) || pic_vec_p(pic, x)) {
2015-06-24 17:44:45 -04:00
int ret;
kh_put(m, h, pic_obj_ptr(x), &ret);
if (ret != 0) {
2014-08-25 00:38:09 -04:00
return true; /* `x' was seen already. */
}
}
}
LOOP:
if (pic_eqv_p(pic, x, y)) {
2014-08-25 00:38:09 -04:00
return true;
2015-06-24 17:44:45 -04:00
}
if (pic_type(pic, x) != pic_type(pic, y)) {
2014-08-25 00:38:09 -04:00
return false;
2015-06-24 17:44:45 -04:00
}
2014-08-25 00:38:09 -04:00
switch (pic_type(pic, x)) {
case PIC_TYPE_ID: {
2016-02-19 15:18:13 -05:00
pic_id *id1, *id2;
2016-02-20 01:31:14 -05:00
pic_value s1, s2;
2015-06-24 17:44:45 -04:00
2016-02-20 01:59:06 -05:00
id1 = pic_id_ptr(pic, x);
id2 = pic_id_ptr(pic, y);
2014-08-25 00:38:09 -04:00
2016-02-20 02:33:51 -05:00
s1 = pic_find_identifier(pic, pic_obj_value(id1->u.id), pic_obj_value(id1->env));
s2 = pic_find_identifier(pic, pic_obj_value(id2->u.id), pic_obj_value(id2->env));
2016-02-20 01:31:14 -05:00
return pic_eq_p(pic, s1, s2);
2015-06-24 17:44:45 -04:00
}
case PIC_TYPE_STRING: {
2016-02-19 13:26:52 -05:00
return pic_str_cmp(pic, x, y) == 0;
2015-06-24 17:44:45 -04:00
}
case PIC_TYPE_BLOB: {
2016-02-19 09:22:41 -05:00
int xlen, ylen;
const unsigned char *xbuf, *ybuf;
2015-06-24 17:44:45 -04:00
2016-02-19 09:22:41 -05:00
xbuf = pic_blob(pic, x, &xlen);
ybuf = pic_blob(pic, y, &ylen);
2014-08-25 00:38:09 -04:00
2016-02-19 09:22:41 -05:00
if (xlen != ylen) {
2015-06-24 17:44:45 -04:00
return false;
}
2016-02-19 09:22:41 -05:00
if (memcmp(xbuf, ybuf, xlen) != 0) {
return false;
2015-06-24 17:44:45 -04:00
}
return true;
}
case PIC_TYPE_PAIR: {
2015-06-24 17:44:45 -04:00
if (! internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, h))
return false;
/* Floyd's cycle-finding algorithm */
if (pic_nil_p(pic, localx)) {
2015-12-27 21:27:26 -05:00
localx = x;
2014-08-25 00:38:09 -04:00
}
2015-06-24 17:44:45 -04:00
x = pic_cdr(pic, x);
2015-12-27 21:27:26 -05:00
cx++;
if (pic_nil_p(pic, localy)) {
2015-12-27 21:27:26 -05:00
localy = y;
}
2015-06-24 17:44:45 -04:00
y = pic_cdr(pic, y);
2015-12-27 21:27:26 -05:00
cy++;
if (cx == 2) {
cx = 0;
localx = pic_cdr(pic, localx);
if (pic_eq_p(pic, localx, x)) {
2015-12-27 21:27:26 -05:00
if (cy < 0 ) return true; /* both lists circular */
cx = INT_MIN; /* found a cycle on x */
}
}
if (cy == 2) {
cy = 0;
localy = pic_cdr(pic, localy);
if (pic_eq_p(pic, localy, y)) {
2015-12-27 21:27:26 -05:00
if (cx < 0 ) return true; /* both lists circular */
cy = INT_MIN; /* found a cycle on y */
2014-08-25 00:38:09 -04:00
}
}
2015-06-24 17:44:45 -04:00
goto LOOP; /* tail-call optimization */
2014-08-25 00:38:09 -04:00
}
case PIC_TYPE_VECTOR: {
2016-02-19 07:56:45 -05:00
int i, xlen, ylen;
2014-08-25 00:38:09 -04:00
2016-02-19 07:56:45 -05:00
xlen = pic_vec_len(pic, x);
ylen = pic_vec_len(pic, y);
2014-08-25 00:38:09 -04:00
2016-02-19 07:56:45 -05:00
if (xlen != ylen) {
2014-08-25 00:38:09 -04:00
return false;
}
2016-02-19 07:56:45 -05:00
for (i = 0; i < xlen; ++i) {
if (! internal_equal_p(pic, pic_vec_ref(pic, x, i), pic_vec_ref(pic, y, i), depth + 1, h))
2014-08-25 00:38:09 -04:00
return false;
}
return true;
}
case PIC_TYPE_DATA: {
2016-02-19 09:30:47 -05:00
return pic_data(pic, x) == pic_data(pic, y);
}
2014-08-25 00:38:09 -04:00
default:
return false;
}
}
bool
pic_equal_p(pic_state *pic, pic_value x, pic_value y)
{
2015-06-24 17:44:45 -04:00
khash_t(m) h;
kh_init(m, &h);
2014-08-25 00:38:09 -04:00
2015-06-24 17:44:45 -04:00
return internal_equal_p(pic, x, y, 0, &h);
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_bool_eq_p(pic_state *pic)
{
pic_value x, y;
pic_get_args(pic, "oo", &x, &y);
return pic_bool_value(pic, pic_eq_p(pic, x, y));
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_bool_eqv_p(pic_state *pic)
{
pic_value x, y;
pic_get_args(pic, "oo", &x, &y);
return pic_bool_value(pic, pic_eqv_p(pic, x, y));
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_bool_equal_p(pic_state *pic)
{
pic_value x, y;
pic_get_args(pic, "oo", &x, &y);
return pic_bool_value(pic, pic_equal_p(pic, x, y));
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_bool_not(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_false_p(pic, v) ? pic_true_value(pic) : pic_false_value(pic);
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_bool_boolean_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return (pic_true_p(pic, v) || pic_false_p(pic, v)) ? pic_true_value(pic) : pic_false_value(pic);
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_bool_boolean_eq_p(pic_state *pic)
{
2015-08-26 06:04:27 -04:00
int argc, i;
2014-08-25 00:38:09 -04:00
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < argc; ++i) {
if (! (pic_true_p(pic, argv[i]) || pic_false_p(pic, argv[i]))) {
return pic_false_value(pic);
2014-08-25 00:38:09 -04:00
}
if (! pic_eq_p(pic, argv[i], argv[0])) {
return pic_false_value(pic);
2014-08-25 00:38:09 -04:00
}
}
return pic_true_value(pic);
2014-08-25 00:38:09 -04:00
}
void
pic_init_bool(pic_state *pic)
{
pic_defun(pic, "eq?", pic_bool_eq_p);
pic_defun(pic, "eqv?", pic_bool_eqv_p);
pic_defun(pic, "equal?", pic_bool_equal_p);
2015-07-01 17:17:27 -04:00
pic_defun(pic, "not", pic_bool_not);
2015-06-04 00:53:41 -04:00
2014-08-25 00:38:09 -04:00
pic_defun(pic, "boolean?", pic_bool_boolean_p);
pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);
}