picrin/symbol.c

164 lines
3.1 KiB
C

/**
* See Copyright Notice in picrin.h
*/
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include "picrin.h"
#include "picrin/string.h"
pic_sym
pic_intern(pic_state *pic, const char *str, size_t len)
{
char *cstr;
xh_entry *e;
pic_sym id;
cstr = (char *)pic_malloc(pic, len + 1);
cstr[len] = '\0';
memcpy(cstr, str, len);
e = xh_get_str(&pic->syms, cstr);
if (e) {
return xh_val(e, pic_sym);
}
id = pic->sym_cnt++;
xh_put_str(&pic->syms, cstr, &id);
xh_put_int(&pic->sym_names, id, &cstr);
return id;
}
pic_sym
pic_intern_cstr(pic_state *pic, const char *str)
{
return pic_intern(pic, str, strlen(str));
}
pic_sym
pic_intern_str(pic_state *pic, pic_str *str)
{
return pic_intern_cstr(pic, pic_str_cstr(str));
}
pic_sym
pic_gensym(pic_state *pic, pic_sym base)
{
int uid = pic->uniq_sym_cnt++, len;
char *str, mark;
pic_sym uniq;
if (pic_interned_p(pic, base)) {
mark = '@';
} else {
mark = '.';
}
len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
str = pic_alloc(pic, (size_t)len + 1);
sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
/* don't put the symbol to pic->syms to keep it uninterned */
uniq = pic->sym_cnt++;
xh_put_int(&pic->sym_names, uniq, &str);
return uniq;
}
pic_sym
pic_ungensym(pic_state *pic, pic_sym base)
{
const char *name, *occr;
if (pic_interned_p(pic, base)) {
return base;
}
name = pic_symbol_name(pic, base);
if ((occr = strrchr(name, '@')) == NULL) {
pic_panic(pic, "logic flaw");
}
return pic_intern(pic, name, (size_t)(occr - name));
}
bool
pic_interned_p(pic_state *pic, pic_sym sym)
{
return sym == pic_intern_cstr(pic, pic_symbol_name(pic, sym));
}
const char *
pic_symbol_name(pic_state *pic, pic_sym sym)
{
return xh_val(xh_get_int(&pic->sym_names, sym), const char *);
}
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)
{
int argc, i;
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)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (! pic_sym_p(v)) {
pic_errorf(pic, "symbol->string: expected symbol");
}
return pic_obj_value(pic_make_str_cstr(pic, pic_symbol_name(pic, pic_sym(v))));
}
static pic_value
pic_symbol_string_to_symbol(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (! pic_str_p(v)) {
pic_errorf(pic, "string->symbol: expected string");
}
return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v))));
}
void
pic_init_symbol(pic_state *pic)
{
pic_defun(pic, "symbol?", pic_symbol_symbol_p);
pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string);
pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol);
pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p);
}