static pic_value
pic_str_list_to_string(pic_state *pic)
{
pic_str *str;
pic_value list, e, it;
int i;
char *buf;
pic_get_args(pic, "o", &list);
if (pic_length(pic, list) == 0) {
return pic_obj_value(pic_make_str(pic, NULL, 0));
}
buf = pic_malloc(pic, pic_length(pic, list));
pic_try {
i = 0;
pic_for_each (e, list, it) {
pic_assert_type(pic, e, char);
buf[i++] = pic_char(e);
}
str = pic_make_str(pic, buf, i);
}
pic_str *
pic_get_backtrace(pic_state *pic)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_callinfo *ci;
pic_str *trace;
trace = pic_make_str(pic, NULL, 0);
for (ci = pic->ci; ci != pic->cibase; --ci) {
struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " at "));
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));
if (pic_proc_func_p(proc)) {
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));
} else if (pic_proc_irep_p(proc)) {
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */
}
}
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, pic_obj_value(trace));
return trace;
}
static pic_value
pic_vec_vector_to_string(pic_state *pic)
{
pic_vec *vec;
char *buf;
int n, start, end, i;
pic_str *str;
n = pic_get_args(pic, "v|ii", &vec, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = vec->len;
}
if (end < start) {
pic_errorf(pic, "vector->string: end index must not be less than start index");
}
buf = pic_malloc(pic, end - start);
for (i = start; i < end; ++i) {
pic_assert_type(pic, vec->data[i], char);
buf[i - start] = pic_char(vec->data[i]);
}
str = pic_make_str(pic, buf, end - start);
pic_free(pic, buf);
return pic_obj_value(str);
}
static pic_value
pic_system_getenvs(pic_state *pic)
{
char **envp;
pic_value data = pic_nil_value();
size_t ai = pic_gc_arena_preserve(pic);
pic_get_args(pic, "");
if (! pic->envp) {
return pic_nil_value();
}
for (envp = pic->envp; *envp; ++envp) {
pic_str *key, *val;
size_t i;
for (i = 0; (*envp)[i] != '='; ++i)
;
key = pic_make_str(pic, *envp, i);
val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key)));
/* push */
data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, data);
}
return data;
}
static pic_value
pic_str_string_map(pic_state *pic)
{
struct pic_proc *proc;
pic_value *argv, vals, val;
int argc, i, len, j;
pic_str *str;
char *buf;
pic_get_args(pic, "l*", &proc, &argc, &argv);
if (argc == 0) {
pic_errorf(pic, "string-map: one or more strings expected, but got zero");
} else {
pic_assert_type(pic, argv[0], str);
len = pic_str_len(pic_str_ptr(argv[0]));
}
for (i = 1; i < argc; ++i) {
pic_assert_type(pic, argv[i], str);
len = len < pic_str_len(pic_str_ptr(argv[i]))
? len
: pic_str_len(pic_str_ptr(argv[i]));
}
buf = pic_malloc(pic, len);
pic_try {
for (i = 0; i < len; ++i) {
vals = pic_nil_value();
for (j = 0; j < argc; ++j) {
pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals);
}
val = pic_apply_list(pic, proc, vals);
pic_assert_type(pic, val, char);
buf[i] = pic_char(val);
}
str = pic_make_str(pic, buf, len);
}
pic_catch {
pic_free(pic, buf);
pic_raise(pic, pic->err);
}
pic_free(pic, buf);
return pic_obj_value(str);
}
struct pic_string *
pic_get_output_string(pic_state *pic, struct pic_port *port)
{
size_t size;
char *buf;
/* get endpos */
xfflush(port->file);
size = (size_t)xftell(port->file);
xrewind(port->file);
/* copy to buf */
buf = (char *)pic_alloc(pic, size + 1);
buf[size] = 0;
xfread(buf, size, 1, port->file);
return pic_make_str(pic, buf, size);
}
static pic_value
pic_str_string_append(pic_state *pic)
{
int argc, i;
pic_value *argv;
pic_str *str;
pic_get_args(pic, "*", &argc, &argv);
str = pic_make_str(pic, NULL, 0);
for (i = 0; i < argc; ++i) {
if (! pic_str_p(argv[i])) {
pic_errorf(pic, "type error");
}
str = pic_str_cat(pic, str, pic_str_ptr(argv[i]));
}
return pic_obj_value(str);
}
static pic_value
pic_str_make_string(pic_state *pic)
{
int len;
char c = ' ';
char *buf;
pic_value ret;
pic_get_args(pic, "i|c", &len, &c);
buf = pic_malloc(pic, len);
memset(buf, c, len);
ret = pic_obj_value(pic_make_str(pic, buf, len));
pic_free(pic, buf);
return ret;
}
void
pic_str_set(pic_state *pic, pic_str *str, int i, char c)
{
pic_str *x, *y, *z, *tmp;
char buf[1];
if (pic_str_len(str) <= i) {
pic_errorf(pic, "index out of range %d", i);
}
buf[0] = c;
x = pic_str_sub(pic, str, 0, i);
y = pic_make_str(pic, buf, 1);
z = pic_str_sub(pic, str, i + 1, pic_str_len(str));
tmp = pic_str_cat(pic, x, pic_str_cat(pic, y, z));
pic_rope_incref(pic, tmp->rope);
pic_rope_decref(pic, str->rope);
str->rope = tmp->rope;
}
static pic_value
pic_str_string(pic_state *pic)
{
int argc, i;
pic_value *argv;
pic_str *str;
char *buf;
pic_get_args(pic, "*", &argc, &argv);
buf = pic_malloc(pic, argc);
for (i = 0; i < argc; ++i) {
pic_assert_type(pic, argv[i], char);
buf[i] = pic_char(argv[i]);
}
str = pic_make_str(pic, buf, argc);
pic_free(pic, buf);
return pic_obj_value(str);
}
pic_str *
pic_make_str_cstr(pic_state *pic, const char *cstr)
{
return pic_make_str(pic, cstr, strlen(cstr));
}
pic_sym *
pic_intern_cstr(pic_state *pic, const char *str)
{
return pic_intern(pic, pic_make_str(pic, str, strlen(str)));
}
