picrin/lib/symbol.c

204 lines
4.2 KiB
C
Raw Normal View History

2014-08-25 00:38:09 -04:00
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
2017-03-28 10:09:40 -04:00
#include "object.h"
#include "state.h"
2014-08-25 00:38:09 -04:00
2017-03-30 03:19:20 -04:00
#define to_cstr(a) (pic_str(pic, obj_value(pic, a), NULL))
#define kh_pic_str_hash(a) (kh_str_hash_func(to_cstr(a)))
#define kh_pic_str_cmp(a, b) (kh_str_cmp_func(to_cstr(a), to_cstr(b)))
2015-06-24 18:05:41 -04:00
2016-02-21 06:32:00 -05:00
KHASH_DEFINE(oblist, struct string *, symbol *, kh_pic_str_hash, kh_pic_str_cmp)
2016-02-20 01:31:14 -05:00
pic_value
2016-02-19 13:26:52 -05:00
pic_intern(pic_state *pic, pic_value str)
2014-08-25 00:38:09 -04:00
{
2016-02-14 22:59:58 -05:00
khash_t(oblist) *h = &pic->oblist;
symbol *sym;
2016-02-20 11:52:34 -05:00
int it;
2015-06-24 18:05:41 -04:00
int ret;
2014-08-25 00:38:09 -04:00
2016-02-19 13:26:52 -05:00
it = kh_put(oblist, h, pic_str_ptr(pic, str), &ret);
2015-06-24 18:05:41 -04:00
if (ret == 0) { /* if exists */
sym = kh_val(h, it);
pic_protect(pic, obj_value(pic, sym));
return obj_value(pic, sym);
2014-08-25 00:38:09 -04:00
}
2016-02-20 14:34:26 -05:00
kh_val(h, it) = NULL; /* dummy */
2016-02-14 03:13:38 -05:00
sym = (symbol *)pic_obj_alloc(pic, offsetof(symbol, env), PIC_TYPE_SYMBOL);
2016-02-19 15:18:13 -05:00
sym->u.str = pic_str_ptr(pic, str);
2015-06-24 18:05:41 -04:00
kh_val(h, it) = sym;
return obj_value(pic, sym);
2014-08-25 00:38:09 -04:00
}
2016-02-20 01:59:06 -05:00
pic_value
2016-02-20 02:33:51 -05:00
pic_make_identifier(pic_state *pic, pic_value base, pic_value env)
2016-02-06 09:15:53 -05:00
{
2016-02-21 06:32:00 -05:00
struct identifier *id;
2016-02-06 09:15:53 -05:00
2016-02-21 06:32:00 -05:00
id = (struct identifier *)pic_obj_alloc(pic, sizeof(struct identifier), PIC_TYPE_ID);
id->u.id = pic_id_ptr(pic, base);
2016-02-20 02:33:51 -05:00
id->env = pic_env_ptr(pic, env);
2016-02-20 01:59:06 -05:00
return obj_value(pic, id);
2016-02-06 09:15:53 -05:00
}
2016-02-19 13:26:52 -05:00
pic_value
2016-02-21 05:19:35 -05:00
pic_sym_name(pic_state *PIC_UNUSED(pic), pic_value sym)
2014-08-25 00:38:09 -04:00
{
return obj_value(pic, pic_sym_ptr(pic, sym)->u.str);
2014-08-25 00:38:09 -04:00
}
2016-02-19 13:26:52 -05:00
pic_value
2016-02-20 01:59:06 -05:00
pic_id_name(pic_state *pic, pic_value id)
2016-02-06 09:15:53 -05:00
{
2016-02-20 01:59:06 -05:00
while (! pic_sym_p(pic, id)) {
id = obj_value(pic, pic_id_ptr(pic, id)->u.id);
2016-02-06 09:15:53 -05:00
}
2016-02-20 01:59:06 -05:00
return pic_sym_name(pic, id);
2016-02-06 09:15:53 -05:00
}
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, pic_sym_p(pic, v));
2014-08-25 00:38:09 -04:00
}
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(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
}
static pic_value
pic_symbol_symbol_to_string(pic_state *pic)
{
2016-02-20 01:31:14 -05:00
pic_value 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-20 01:31:14 -05:00
return pic_sym_name(pic, sym);
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_symbol_string_to_symbol(pic_state *pic)
{
2016-02-19 13:26:52 -05:00
pic_value 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-20 01:31:14 -05:00
return 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, pic_id_p(pic, obj));
2016-02-06 09:15:53 -05:00
}
static pic_value
pic_symbol_make_identifier(pic_state *pic)
{
pic_value id, env;
pic_get_args(pic, "oo", &id, &env);
2016-02-23 08:53:20 -05:00
TYPE_CHECK(pic, id, id);
TYPE_CHECK(pic, env, env);
2016-02-06 09:15:53 -05:00
2016-02-20 02:33:51 -05:00
return pic_make_identifier(pic, id, env);
2016-02-06 09:15:53 -05:00
}
static pic_value
pic_symbol_identifier_base(pic_state *pic)
2016-02-06 09:15:53 -05:00
{
pic_value id;
pic_get_args(pic, "o", &id);
2016-02-23 08:53:20 -05:00
TYPE_CHECK(pic, id, id);
2016-02-06 09:15:53 -05:00
if (pic_sym_p(pic, id)) {
2016-02-22 14:03:42 -05:00
pic_error(pic, "non-symbol identifier required", 1, id);
2016-02-06 09:15:53 -05:00
}
return obj_value(pic, pic_id_ptr(pic, id)->u.id);
2016-02-06 09:15:53 -05:00
}
static pic_value
pic_symbol_identifier_environment(pic_state *pic)
{
pic_value id;
pic_get_args(pic, "o", &id);
2016-02-23 08:53:20 -05:00
TYPE_CHECK(pic, id, id);
2016-02-06 09:15:53 -05:00
if (pic_sym_p(pic, id)) {
2016-02-22 14:03:42 -05:00
pic_error(pic, "non-symbol identifier required", 1, id);
2016-02-06 09:15:53 -05:00
}
return obj_value(pic, pic_id_ptr(pic, id)->env);
2016-02-06 09:15:53 -05:00
}
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(pic, argv[i])) {
return pic_false_value(pic);
2016-02-06 09:15:53 -05:00
}
if (! pic_equal_p(pic, argv[i], argv[0])) {
return pic_false_value(pic);
2016-02-06 09:15:53 -05:00
}
}
return pic_true_value(pic);
2016-02-06 09:15:53 -05:00
}
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-base", pic_symbol_identifier_base);
2016-02-06 09:15:53 -05:00
pic_defun(pic, "identifier-environment", pic_symbol_identifier_environment);
2014-08-25 00:38:09 -04:00
}