/**
* dup an object
*/
lv_t *lisp_dup_item(lv_t *v) {
lv_t *r;
lv_t *vptr = v;
lv_t *rptr;
assert(v);
switch(v->type) {
case l_int:
r = lisp_create_int(0);
mpz_set(L_INT(r), L_INT(v));
return r;
case l_rational:
r = lisp_create_rational(1, 1);
mpq_set(L_RAT(r), L_RAT(v));
return r;
case l_float:
r = lisp_create_float(0.0);
mpfr_set(L_FLOAT(r), L_FLOAT(v), MPFR_ROUND_TYPE);
return r;
case l_bool:
return v;
case l_sym:
return lisp_create_symbol(L_SYM(v));
case l_str:
return lisp_create_string(L_STR(v));
case l_null:
return v;
case l_port:
/* can't really copy this -- it's a socket or a file
handle, or something else. */
return v;
case l_char:
return lisp_create_char(L_CHAR(v));
case l_fn:
/* can't really copy this either, but it's essentially
immutable */
return v;
case l_err:
return lisp_create_err(L_ERR(v));
case l_hash:
/* FIXME: should really be a copy */
return v;
case l_pair:
r = lisp_create_pair(NULL, NULL);
rptr = r;
while(vptr && L_CAR(vptr)) {
L_CAR(rptr) = lisp_dup_item(L_CAR(vptr));
vptr = L_CDR(vptr);
if(vptr) {
L_CDR(rptr) = lisp_create_pair(NULL, NULL);
rptr = L_CDR(rptr);
}
}
return r;
}
assert(0);
}
lv_t *lisp_create_type(void *value, lisp_type_t type) {
lv_t *result;
result = safe_malloc(sizeof(lv_t));
result->type = type;
result->row = 0;
result->col = 0;
result->file = NULL;
switch(type) {
case l_char:
L_CHAR(result) = *((char*)value);
break;
case l_int:
mpz_init(L_INT(result));
mpz_set_si(L_INT(result), *(int64_t *)value);
break;
case l_rational:
mpq_init(L_RAT(result));
break;
case l_float:
mpfr_init(L_FLOAT(result));
mpfr_set_d(L_FLOAT(result), *(double*)value, MPFR_ROUND_TYPE);
break;
case l_bool:
L_BOOL(result) = *((int*)value);
break;
case l_sym:
L_SYM(result) = safe_strdup((char*)value);
break;
case l_str:
L_STR(result) = safe_strdup((char*)value);
break;
case l_err:
L_ERR(result) = *((lisp_errsubtype_t *)value);
break;
case l_fn:
L_FN(result) = (lisp_method_t)value;
break;
case l_port:
L_PORT(result) = (port_info_t *)value;
break;
default:
assert(0);
fprintf(stderr, "Bad type");
exit(EXIT_FAILURE);
}
return result;
}
/**
* c helper for equalp
*/
int c_equalp(lv_t *a1, lv_t *a2) {
int result = 0;
if(a1->type != a2->type)
return 0;
switch(a1->type) {
case l_int:
result = (mpz_cmp(L_INT(a1), L_INT(a2)) == 0);
break;
case l_float:
result = (mpfr_cmp(L_FLOAT(a1), L_FLOAT(a2)) == 0);
break;
case l_bool:
if((L_BOOL(a1) == 0 && L_BOOL(a2) == 0) ||
(L_BOOL(a1) != 0 && L_BOOL(a1) != 0))
result = 1;
break;
case l_sym:
if(strcmp(L_SYM(a1), L_SYM(a2)) == 0)
result = 1;
break;
case l_str:
if(strcmp(L_STR(a1), L_STR(a2)) == 0)
result = 1;
break;
case l_hash:
result = (L_HASH(a1) == L_HASH(a2));
break;
case l_null:
result = 1;
break;
case l_fn:
result = (L_FN(a1) == L_FN(a1));
break;
case l_pair:
/* this is perhaps not right */
if(!(c_equalp(L_CAR(a1), L_CAR(a2))))
return 0;
if(L_CDR(a1) && L_CDR(a2))
return c_equalp(L_CDR(a1), L_CDR(a2));
if(!L_CDR(a1) && !L_CDR(a2))
return 1;
result = 0;
break;
}
return result;
}
LObject *
lipa_new_int (gint i)
{
LObject *obj = g_new0 (LObject, 1);
obj->type = L_OBJ_INT;
L_INT (obj) = (i);
return obj;
}
/**
* lisp_create_type for int, using the string parser
* (to be able to represent arbitrary precision). This
* is the preferred interface
*/
lv_t *lisp_create_int_str(char *value) {
int64_t v = 0;
int flag;
lv_t *new_value = lisp_create_type((void*)&v, l_int);
/* now parse the string */
flag = mpz_set_str(L_INT(new_value), value, 10);
assert(!flag);
return new_value;
}
LObject *
lisp_substring (LObject *args)
{
char *str;
LObject *obj = lipa_new_string ("");
gint x, y, i;
if (!lipa_list_length (args, 3))
{
fputs ("substring wants 3 arguments\n", stderr);
return NULL;
}
if (!STRINGP (lipa_car (args)) || !INTP (lipa_car (lipa_cdr (args))) ||
!INTP (lipa_car (lipa_cdr (lipa_cdr (args)))))
{
fputs ("substring wants 1 string and 2 ints as arguments\n", stderr);
return NULL;
}
x = L_INT (lipa_car (lipa_cdr (args)));
y = L_INT (lipa_car (lipa_cdr (lipa_cdr (args))));
if ((x < 0) || (y > strlen (L_STRING (lipa_car (args))->str)) || (x >= y))
{
fputs ("substring: int arguments out of range\n", stderr);
return NULL;
}
str = strdup (L_STRING (lipa_car (args))->str);
for (i = x; i < y; i++)
{
g_string_append_c (L_STRING (obj), str[i]);
}
return obj;
}
/**
* print a value to a fd, in a debug form
*/
void lisp_dump_value(int fd, lv_t *v, int level) {
switch(v->type) {
case l_null:
dprintf(fd, "()");
break;
case l_int:
dprintf(fd, "%" PRIu64, L_INT(v));
break;
case l_float:
dprintf(fd, "%0.16g", L_FLOAT(v));
break;
case l_bool:
dprintf(fd, "%s", L_BOOL(v) ? "#t": "#f");
break;
case l_sym:
dprintf(fd, "%s", L_SYM(v));
break;
case l_str:
dprintf(fd, "\"%s\"", L_STR(v));
break;
case l_char:
dprintf(fd, "#\%02x", L_CHAR(v));
break;
case l_pair:
dprintf(fd, "(");
lv_t *vp = v;
while(vp && L_CAR(vp)) {
lisp_dump_value(fd, L_CAR(vp), level + 1);
if(L_CDR(vp) && (L_CDR(vp)->type != l_pair)) {
dprintf(fd, " . ");
lisp_dump_value(fd, L_CDR(vp), level + 1);
vp = NULL;
} else {
vp = L_CDR(vp);
dprintf(fd, "%s", vp ? " " : "");
}
}
dprintf(fd, ")");
break;
case l_fn:
if(L_FN(v) == NULL)
dprintf(fd, "<lambda@%p>", v);
else
dprintf(fd, "<built-in@%p>", v);
break;
default:
// missing a type check.
assert(0);
}
}
static LObject *
lisp_string_length (LObject *args)
{
LObject *obj = lipa_new_int (0);
if (!lipa_list_length (args, 1))
{
fputs ("string-length wants 1 argument\n", stderr);
return NULL;
}
if (!STRINGP (lipa_car (args)))
{
fputs ("string-length wants a string argument\n", stderr);
return NULL;
}
L_INT (obj) = strlen (L_STRING (lipa_car (args))->str);
return obj;
}
/**
* (list-tail list k)
*
* return the sublist of list obtained by omitting the first k elements
*/
lv_t *p_list_tail(lexec_t *exec, lv_t *v) {
lv_t *r, *a0, *a1;
int k;
assert(exec && v);
assert((v->type == l_pair) || (v->type == l_null));
rt_assert(c_list_length(v) == 2, le_arity, "expecting 2 args");
a0 = L_CAR(v);
a1 = L_CADR(v);
rt_assert(a0->type == l_pair, le_type, "expecting list as arg0");
rt_assert(a1->type == l_int, le_type, "expecting int as arg1");
k = mpz_get_si(L_INT(a1));
r = lisp_get_kth(a0, k);
rt_assert(r, le_type, "list too short");
return r;
}
/**
* print the object specified by v in the provided buffer.
* follows standard snprintf rules, in that it returns the
* number of bytes required to print if an insufficient buffer
* length is provided.
*
* if display is true, then the results are printed as human
* readable (p_display), otherwise it is printed as machine
* readable (p_write)
*/
int lisp_snprintf(lexec_t *exec, char *buf, int len, lv_t *v, int display) {
int pair_len = 0;
switch(v->type) {
case l_null:
return snprintf(buf, len, "()");
case l_int:
/* return snprintf(buf, len, "%" PRIu64, L_INT(v)); */
return gmp_snprintf(buf, len, "%Zd", L_INT(v));
case l_rational:
return gmp_snprintf(buf, len, "%Qd", L_RAT(v));
case l_float:
/* return snprintf(buf, len, "%0.16g", L_FLOAT(v)); */
return mpfr_snprintf(buf, len, "%Rg", L_FLOAT(v));
case l_bool:
return snprintf(buf, len, "%s", L_BOOL(v) ? "#t": "#f");
case l_sym:
return snprintf(buf, len, "%s", L_SYM(v));
case l_str:
if(display)
return snprintf(buf, len, "%s", L_STR(v));
else
return snprintf(buf, len, "\"%s\"", L_STR(v));
case l_pair:
if(len >= 1)
sprintf(buf, "(");
pair_len += 1;
lv_t *vp = v;
while(vp && L_CAR(vp)) {
pair_len += lisp_snprintf(exec, buf + pair_len,
(len - pair_len) > 0 ? len - pair_len : 0,
L_CAR(vp), display);
if(L_CDR(vp) && (L_CDR(vp)->type != l_pair)) {
pair_len += snprintf(buf + pair_len,
(len - pair_len) > 0 ? len - pair_len : 0,
" . ");
pair_len += lisp_snprintf(exec, buf + pair_len,
(len - pair_len) > 0 ? len - pair_len : 0,
L_CDR(vp), display);
vp = NULL;
} else {
vp = L_CDR(vp);
if(vp) {
if (len - pair_len > 0)
snprintf(buf + pair_len, len - pair_len, " ");
pair_len++;
}
}
}
if (len - pair_len > 0) {
sprintf(buf + pair_len, ")");
}
pair_len++;
return pair_len;
break;
case l_fn:
rt_assert(!display, le_type, "cannot display function types");
if(L_FN(v) == NULL)
return snprintf(buf, len, "<lambda@%p>", v);
else
return snprintf(buf, len, "<built-in@%p>", v);
break;
case l_char:
if(display)
return snprintf(buf, len, "%c", L_CHAR(v));
else
return snprintf(buf, len, "#\\x%02x", L_CHAR(v));
break;
case l_port:
rt_assert(!display, le_type, "cannot display port types");
return snprintf(buf, len, "<port@%p>", v);
break;
case l_err:
rt_assert(!display, le_type, "cannot display error types");
return snprintf(buf, len, "<error@%p:%d>", v, L_ERR(v));
break;
default:
// missing a type check.
assert(0);
}
}