picrin/extlib/benz/symbol.c

198 lines
3.9 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-07 13:36:20 -05:00
#define kh_pic_str_hash(a) (pic_str_hash(pic, (a)))
#define kh_pic_str_cmp(a, b) (pic_str_cmp(pic, (a), (b)) == 0)
2015-06-24 18:05:41 -04:00
2016-02-07 13:36:20 -05:00
KHASH_DEFINE(s, pic_str *, pic_sym *, kh_pic_str_hash, kh_pic_str_cmp)
2015-01-20 02:02:28 -05:00
pic_sym *
2016-02-07 14:10:22 -05:00
pic_intern(pic_state *pic, pic_str *str)
2014-08-25 00:38:09 -04:00
{
khash_t(s) *h = &pic->oblist;
2015-01-20 02:02:28 -05:00
pic_sym *sym;
2015-06-24 18:05:41 -04:00
khiter_t it;
int ret;
2014-08-25 00:38:09 -04:00
2016-02-07 13:36:20 -05:00
it = kh_put(s, h, str, &ret);
2015-06-24 18:05:41 -04:00
if (ret == 0) { /* if exists */
sym = kh_val(h, it);
pic_gc_protect(pic, pic_obj_value(sym));
return sym;
2014-08-25 00:38:09 -04:00
}
2015-06-25 13:32:59 -04:00
sym = (pic_sym *)pic_obj_alloc(pic, sizeof(pic_sym), PIC_TT_SYMBOL);
2016-02-07 13:36:20 -05:00
sym->str = str;
2015-06-24 18:05:41 -04:00
kh_val(h, it) = sym;
return sym;
2014-08-25 00:38:09 -04:00
}
2016-02-06 09:15:53 -05:00
pic_id *
pic_make_identifier(pic_state *pic, pic_id *id, struct pic_env *env)
{
pic_id *nid;
nid = (pic_id *)pic_obj_alloc(pic, sizeof(pic_id), PIC_TT_ID);
nid->u.id.id = id;
nid->u.id.env = env;
return nid;
}
2014-08-25 00:38:09 -04:00
const char *
2016-02-07 13:36:20 -05:00
pic_symbol_name(pic_state *pic, pic_sym *sym)
2014-08-25 00:38:09 -04:00
{
2016-02-07 13:36:20 -05:00
return pic_str_cstr(pic, sym->str);
2014-08-25 00:38:09 -04:00
}
2016-02-06 09:15:53 -05:00
const char *
pic_identifier_name(pic_state *pic, pic_id *id)
{
while (! pic_sym_p(pic_obj_value(id))) {
id = id->u.id.id;
}
return pic_symbol_name(pic, (pic_sym *)id);
}
2014-08-25 00:38:09 -04:00
static pic_value
pic_symbol_symbol_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_sym_p(v));
}
static pic_value
pic_symbol_symbol_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_sym_p(argv[i])) {
return pic_false_value();
}
if (! pic_eq_p(argv[i], argv[0])) {
return pic_false_value();
}
}
return pic_true_value();
}
static pic_value
pic_symbol_symbol_to_string(pic_state *pic)
{
2015-01-20 02:02:28 -05:00
pic_sym *sym;
2014-08-25 00:38:09 -04:00
pic_get_args(pic, "m", &sym);
2014-08-25 00:38:09 -04:00
2016-02-07 13:36:20 -05:00
return pic_obj_value(sym->str);
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_symbol_string_to_symbol(pic_state *pic)
{
pic_str *str;
2014-08-25 00:38:09 -04:00
pic_get_args(pic, "s", &str);
2014-08-25 00:38:09 -04:00
2016-02-07 14:10:22 -05:00
return pic_obj_value(pic_intern(pic, str));
2014-08-25 00:38:09 -04:00
}
2016-02-06 09:15:53 -05:00
static pic_value
pic_symbol_identifier_p(pic_state *pic)
{
pic_value obj;
pic_get_args(pic, "o", &obj);
return pic_bool_value(pic_id_p(obj));
}
static pic_value
pic_symbol_make_identifier(pic_state *pic)
{
pic_value id, env;
pic_get_args(pic, "oo", &id, &env);
pic_assert_type(pic, id, id);
pic_assert_type(pic, env, env);
return pic_obj_value(pic_make_identifier(pic, pic_id_ptr(id), pic_env_ptr(env)));
}
static pic_value
pic_symbol_identifier_variable(pic_state *pic)
{
pic_value id;
pic_get_args(pic, "o", &id);
pic_assert_type(pic, id, id);
if (pic_sym_p(id)) {
pic_errorf(pic, "expected non-symbol identifier, but got symbol ~s", id);
}
return pic_obj_value(pic_id_ptr(id)->u.id.id);
}
static pic_value
pic_symbol_identifier_environment(pic_state *pic)
{
pic_value id;
pic_get_args(pic, "o", &id);
pic_assert_type(pic, id, id);
if (pic_sym_p(id)) {
pic_errorf(pic, "expected non-symbol identifier, but got symbol ~s", id);
}
return pic_obj_value(pic_id_ptr(id)->u.id.env);
}
static pic_value
pic_symbol_identifier_eq_p(pic_state *pic)
{
int argc, i;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < argc; ++i) {
if (! pic_id_p(argv[i])) {
return pic_false_value();
}
if (! pic_equal_p(pic, argv[i], argv[0])) {
return pic_false_value();
}
}
return pic_true_value();
}
2014-08-25 00:38:09 -04:00
void
pic_init_symbol(pic_state *pic)
{
2015-07-01 17:17:27 -04:00
pic_defun(pic, "symbol?", pic_symbol_symbol_p);
2016-02-06 09:15:53 -05:00
pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p);
2014-08-31 22:37:52 -04:00
pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string);
pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol);
2014-08-25 00:38:09 -04:00
2016-02-06 09:15:53 -05:00
pic_defun(pic, "make-identifier", pic_symbol_make_identifier);
pic_defun(pic, "identifier?", pic_symbol_identifier_p);
pic_defun(pic, "identifier=?", pic_symbol_identifier_eq_p);
pic_defun(pic, "identifier-variable", pic_symbol_identifier_variable);
pic_defun(pic, "identifier-environment", pic_symbol_identifier_environment);
2014-08-25 00:38:09 -04:00
}