LObject *
lisp_char_smallerp (LObject *args)
{
if (!lipa_list_at_least (args, 2) || !CHARP (lipa_car (args)))
{
fputs ("char<? wants at least two arguments\n", stderr);
return NULL;
}
while (lipa_cdr (args))
{
if (!CHARP (lipa_cadr (args)))
{
fputs ("char<? wants char arguments!\n", stderr);
return NULL;
}
else if (L_CHAR (lipa_car (args)) >= (L_CHAR (lipa_cadr (args))))
{
return lisp_false;
}
else
args = (lipa_cdr (args));
}
return lisp_true;
}
LObject *
lisp_char_greater_or_equalp_ci (LObject *args)
{
if (!lipa_list_at_least (args, 2) || !CHARP (lipa_car (args)))
{
fputs ("char-ci>=? wants at least two arguments\n", stderr);
return NULL;
}
while (lipa_cdr (args))
{
if (!CHARP (lipa_cadr (args)))
{
fputs ("char-ci>=? wants char arguments!\n", stderr);
return NULL;
}
else if (tolower (L_CHAR (lipa_car (args))) <
(tolower (L_CHAR (lipa_cadr (args)))))
{
return lisp_false;
}
else
args = (lipa_cdr (args));
}
return lisp_true;
}
/**
* 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);
}
LObject *
lipa_new_char (guchar c)
{
LObject *obj = g_new0 (LObject, 1);
obj->type = L_OBJ_CHAR;
L_CHAR (obj) = c;
return obj;
}
LObject *
lisp_char_lowerp (LObject *args)
{
if (!lipa_list_length (args, 1) || !CHARP (lipa_car (args)))
{
fputs ("char-lower? wants 1 character argument\n", stderr);
return NULL;
}
return (islower (L_CHAR (lipa_car (args))) ? lisp_true : lisp_false);
}
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;
}
/**
* 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);
}
}