cl_object
cl_copy_list(cl_object x)
{
cl_object copy;
if (ecl_unlikely(!LISTP(x))) {
FEwrong_type_only_arg(ecl_make_fixnum(/*COPY-LIST*/257), x, ecl_make_fixnum(/*LIST*/481));
}
copy = ECL_NIL;
if (!Null(x)) {
cl_object tail = copy = ecl_list1(CAR(x));
while (x = ECL_CONS_CDR(x), CONSP(x)) {
cl_object cons = ecl_list1(ECL_CONS_CAR(x));
ECL_RPLACD(tail, cons);
tail = cons;
}
ECL_RPLACD(tail, x);
}
{
#line 441
const cl_env_ptr the_env = ecl_process_env();
#line 441
#line 441
cl_object __value0 = copy;
#line 441
the_env->nvalues = 1;
#line 441
return __value0;
#line 441
}
;
}
cl_object
si_proper_list_p(cl_object x)
{
cl_fixnum n;
cl_object fast, slow, test = ECL_T;
/* INV: A list's length always fits in a fixnum */
fast = slow = x;
for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) {
if (!LISTP(fast)) {
test = ECL_NIL;
break;
}
if (n & 1) {
/* Circular list? */
if (slow == fast) {
test = ECL_NIL;
break;
}
slow = ECL_CONS_CDR(slow);
}
}
{
#line 333
const cl_env_ptr the_env = ecl_process_env();
#line 333
#line 333
cl_object __value0 = test;
#line 333
the_env->nvalues = 1;
#line 333
return __value0;
#line 333
}
;
}
cl_object
ecl_last(cl_object l, cl_index n)
{
/* The algorithm is very simple. We run over the list with
* two pointers, "l" and "r". The separation between both
* must be "n", so that when "l" finds no more conses, "r"
* contains the output. */
cl_object r;
for (r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r))
;
/* If "l" has not moved, we have to ensure that it is a list */
if (r == l) {
if (!LISTP(r)) FEtype_error_list(l);
while (CONSP(r)) {
r = ECL_CONS_CDR(r);
}
return r;
} else if (n == 0) {
while (CONSP(r)) {
r = ECL_CONS_CDR(r);
l = ECL_CONS_CDR(l);
}
return l;
} else {
return l;
}
}
/*
Remf(p, i) removes property i
from the property list pointed by p,
which is a pointer to an cl_object.
The returned value of remf(p, i) is:
TRUE if the property existed
FALSE otherwise.
*/
static bool
remf(cl_object *place, cl_object indicator)
{
cl_object l = *place, tail = ECL_NIL;
while (!Null(l)) {
cl_object ind;
if (!LISTP(l))
FEtype_error_plist(*place);
ind = ECL_CONS_CAR(l);
l = ECL_CONS_CDR(l);
if (!CONSP(l))
FEtype_error_plist(*place);
if (ind == indicator) {
l = ECL_CONS_CDR(l);
if (Null(tail))
*place = l;
else
ECL_RPLACD(tail, l);
return TRUE;
}
tail = l;
l = ECL_CONS_CDR(l);
}
return FALSE;
}
object_t *lisp_cond (object_t * lst)
{
DOC ("Eval car of each argument until one is true. Then eval cdr of\n"
"that argument.");
object_t *p = lst;
while (p != NIL)
{
if (!CONSP (p))
THROW (improper_list, UPREF (lst));
object_t *pair = CAR (p);
if (!CONSP (pair))
THROW (wrong_type, UPREF (pair));
if (!LISTP (CDR (pair)))
THROW (improper_list, UPREF (pair));
if (CDR (pair) == NIL)
return UPREF (CAR (pair));
if (CDR (CDR (pair)) != NIL)
THROW (c_sym ("bad-form"), UPREF (pair));
object_t *r = eval (CAR (pair));
if (r != NIL)
{
obj_destroy (r);
return eval (CAR (CDR (pair)));
}
p = CDR (p);
}
return NIL;
}
void rtti_list_copy(const rtti_t *type, const void *src, void *dst)
{
CHECK_TYPE(LIST);
rtti_list_init(type, dst);
const list_t *shead = LISTP(type, src);
const list_t *pos = shead;
list_for_each(pos, shead) {
src = LISTC(type, pos);
void *entry = malloc(type->size);
type->init(type, entry);
error_dof("failed to initialize list node")
return;
const rtti_field_t *field;
for (field = type->args[0].v; field->name != NULL; field++) {
const void *smemb = MEMBP(field, src);
void *dmemb = MEMBP(field, entry);
field->type->copy(field->type, smemb, dmemb);
error_dof("failed to copy list node (%s)", field->name)
break;
}
error_dof("failed to copy list (%s)", type->name)
return;
rtti_list_add(type, entry, dst);
}
object_t *listp (object_t * lst)
{
DOC ("Return t if object is a list.");
REQ (lst, 1, c_sym ("listp"));
if (LISTP (CAR (lst)))
return T;
return NIL;
}
object_t *lisp_car (object_t * lst)
{
DOC ("Return car element of cons cell.");
REQ (lst, 1, c_sym ("car"));
if (CAR (lst) == NIL)
return NIL;
if (!LISTP (CAR (lst)))
THROW (wrong_type, CAR (lst));
return UPREF (CAR (CAR (lst)));
}
bool
ecl_endp(cl_object x)
{
if (Null(x)) {
return TRUE;
} else if (ecl_unlikely(!LISTP(x))) {
FEwrong_type_only_arg(ecl_make_fixnum(/*ENDP*/330), x, ecl_make_fixnum(/*LIST*/481));
}
return FALSE;
}
object_t *lisp_apply (object_t * lst)
{
DOC ("Apply function to a list.");
REQ (lst, 2, c_sym ("apply"));
object_t *f = CAR (lst);
object_t *args = CAR (CDR (lst));
if (!LISTP (args))
THROW (wrong_type, UPREF (args));
return apply (f, args);
}
static int
prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type,
cl_object arg_types, cl_object args,
cl_object cc_type, ffi_type ***output_copy)
{
int n, ok;
ffi_type **types;
enum ecl_ffi_tag type = ecl_foreign_type_code(return_type);
if (!the_env->ffi_args_limit)
resize_call_stack(the_env, 32);
the_env->ffi_types[0] = ecl_type_to_libffi_type[type];
for (n=0; !Null(arg_types); ) {
if (!LISTP(arg_types)) {
FEerror("In CALL-CFUN, types lists is not a proper list", 0);
}
if (n >= the_env->ffi_args_limit) {
resize_call_stack(the_env, n + 32);
}
type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types));
arg_types = ECL_CONS_CDR(arg_types);
the_env->ffi_types[++n] = ecl_type_to_libffi_type[type];
if (CONSP(args)) {
cl_object object = ECL_CONS_CAR(args);
args = ECL_CONS_CDR(args);
if (type == ECL_FFI_CSTRING) {
object = ecl_null_terminated_base_string(CAR(args));
if (ECL_CONS_CAR(args) != object) {
ECL_STACK_PUSH(the_env, object);
}
}
ecl_foreign_data_set_elt(the_env->ffi_values + n, type, object);
}
}
if (output_copy) {
cl_index bytes = (n + 1) * sizeof(ffi_type*);
*output_copy = types = (ffi_type**)ecl_alloc_atomic(bytes);
memcpy(types, the_env->ffi_types, bytes);
} else {
types = the_env->ffi_types;
}
ok = ffi_prep_cif(cif, ecl_foreign_cc_code(cc_type), n, types[0], types + 1);
if (ok != FFI_OK) {
if (ok == FFI_BAD_ABI) {
FEerror("In CALL-CFUN, not a valid ABI: ~A", 1,
cc_type);
}
if (ok == FFI_BAD_TYPEDEF) {
FEerror("In CALL-CFUN, wrong or malformed argument types", 0);
}
}
return n;
}
cl_index
ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0)
{
cl_object vars = vars0, values = values0;
cl_index n = env->bds_top - env->bds_org;
for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) {
if (Null(vars)) {
return n;
} else {
cl_object var = ECL_CONS_CAR(vars);
if (Null(values)) {
ecl_bds_bind(env, var, OBJNULL);
} else {
ecl_bds_bind(env, var, ECL_CONS_CAR(values));
values = ECL_CONS_CDR(values);
}
}
}
FEerror("Wrong arguments to special form PROGV. Either~%"
"~A~%or~%~A~%are not proper lists",
2, vars0, values0);
}
cl_object
ecl_nthcdr(cl_fixnum n, cl_object x)
{
if (n < 0)
FEtype_error_index(x, n);
while (n-- > 0 && !Null(x)) {
if (LISTP(x)) {
x = ECL_CONS_CDR(x);
} else {
FEtype_error_list(x);
}
}
return x;
}
cl_object
ecl_nth(cl_fixnum n, cl_object x)
{
if (n < 0)
FEtype_error_index(x, n);
/* INV: No need to check for circularity since we visit
at most `n' conses */
for (; n > 0 && CONSP(x); n--)
x = ECL_CONS_CDR(x);
if (Null(x))
return ECL_NIL;
if (!LISTP(x))
FEtype_error_list(x);
return ECL_CONS_CAR(x);
}
void rtti_list_init(const rtti_t *type, void *data)
{
CHECK_TYPE(LIST);
memset(data, 0, type->size);
const rtti_field_t *field;
for (field = type->args[0].v; field->name != NULL; field++) {
void *memb = MEMBP(field, data);
field->type->init(field->type, memb);
error_dof("failed to initialize list (%s)", field->name)
return;
}
list_t *list = LISTP(type, data);
INIT_LIST_HEAD(list);
}
void reconstruct_list(int exp_id) {
if (expression[exp_id] == L_NIL) {
return;
}
output[output_pointer] = ' ';
output_pointer += 1;
reconstruct(CAR(exp_id));
if (LISTP(CDR(exp_id))) {
reconstruct_list(CDR(exp_id));
} else {
output[output_pointer] = ' ';
output[output_pointer + 1] = '.';
output[output_pointer + 2] = ' ';
output_pointer += 3;
reconstruct(CDR(exp_id));
}
}
cl_object
cl_list_length(cl_object x)
{
cl_fixnum n;
cl_object fast, slow;
/* INV: A list's length always fits in a fixnum */
fast = slow = x;
for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) {
if (ecl_unlikely(!LISTP(fast))) {
FEtype_error_list(fast);
}
if (n & 1) {
/* Circular list? */
if (slow == fast) {
#line 305
const cl_env_ptr the_env = ecl_process_env();
#line 305
#line 305
cl_object __value0 = ECL_NIL;
#line 305
the_env->nvalues = 1;
#line 305
return __value0;
#line 305
}
;
slow = ECL_CONS_CDR(slow);
}
}
{
#line 309
const cl_env_ptr the_env = ecl_process_env();
#line 309
#line 309
cl_object __value0 = ecl_make_fixnum(n);
#line 309
the_env->nvalues = 1;
#line 309
return __value0;
#line 309
}
;
}
cl_object
cl_endp(cl_object x)
{
cl_object output = ECL_NIL;
if (Null(x)) {
output = ECL_T;
} else if (ecl_unlikely(!LISTP(x))) {
FEwrong_type_only_arg(ecl_make_fixnum(/*ENDP*/330), x, ecl_make_fixnum(/*LIST*/481));
}
{
#line 278
const cl_env_ptr the_env = ecl_process_env();
#line 278
#line 278
cl_object __value0 = output;
#line 278
the_env->nvalues = 1;
#line 278
return __value0;
#line 278
}
;
}
void reconstruct(int exp_id) {
if (ATOM(exp_id)) {
output_pointer += copy_string(output + output_pointer, id_map + NTH_ATOM(expression[exp_id]));
} else {
output[output_pointer] = '(';
output_pointer += 1;
reconstruct(CAR(exp_id));
if (LISTP(CDR(exp_id))) {
reconstruct_list(CDR(exp_id));
} else {
output[output_pointer] = ' ';
output[output_pointer + 1] = '.';
output[output_pointer + 2] = ' ';
output_pointer += 3;
reconstruct(CDR(exp_id));
}
output[output_pointer] = ')';
output_pointer += 1;
}
}
at *cdr(at *q)
{
ifn (LISTP(q))
RAISEF("not a list", q);
return q ? Cdr(q) : q;
}