glisp/src/list.c

#include "list.h"

#include "function.h"

DEFINE_SYMBOL(circular_list_error, "circular-list-error");
DEFINE_CONDITION_CLASS(circular_list_error, error);

intptr_t list_length(LispVal *list) {
    assert(LISTP(list));
    LispVal *tortise = list;
    LispVal *hare = list;
    intptr_t length = 0;
    while (CONSP(tortise)) {
        tortise = XCDR_SAFE(tortise);
        hare = XCDR_SAFE(XCDR_SAFE(hare));
        if (!NILP(hare) && tortise == hare) {
            return -1;
        }
        ++length;
    }
    return length;
}

bool list_length_eq(LispVal *list, intptr_t size) {
    while (size && CONSP(list)) {
        list = XCDR(list);
        --size;
    }
    return size == 0 && NILP(list);
}

DEFUN(consp, "consp", (LispVal * val), "(val)", "") {
    return CONSP(val) ? Qt : Qnil;
}

DEFUN(atom, "atom", (LispVal * val), "(val)", "") {
    return ATOM(val) ? Qt : Qnil;
}

DEFUN(cons, "cons", (LispVal * car, LispVal *cdr), "(car cdr)",
      "Construct a new cons object from CAR and CDR.") {
    return CONS(car, cdr);
}

DEFUN(car, "car", (LispVal * list), "(list)", "") {
    CHECK_LISTP(list);
    return NILP(list) ? Qnil : XCAR(list);
}

DEFUN(cdr, "cdr", (LispVal * list), "(list)", "") {
    CHECK_LISTP(list);
    return NILP(list) ? Qnil : XCDR(list);
}

DEFUN(rplaca, "rplaca", (LispVal * cons, LispVal *newcar), "(cons newcar)",
      "") {
    CHECK_TYPE(cons, TYPE_CONS);
    RPLACA(cons, newcar);
    return newcar;
}

DEFUN(rplacd, "rplacd", (LispVal * cons, LispVal *newcdr), "(cons newcdr)",
      "") {
    CHECK_TYPE(cons, TYPE_CONS);
    RPLACD(cons, newcdr);
    return newcdr;
}

DEFUN(length_eq, "length=", (LispVal * list, LispVal *length), "(list length)",
      "Return non-nil if LIST's length is LENGTH.") {
    CHECK_LISTP(list);
    return list_length_eq(list, XFIXNUM(length)) ? Qt : Qnil;
}

DEFUN(nreverse, "nreverse", (LispVal * list), "(list)", "") {
    LispVal *rev = Qnil;
    while (!NILP(list)) {
        CHECK_LISTP(list);
        LispVal *next = XCDR(list);
        RPLACD(list, rev);
        rev = list;
        list = next;
    }
    return rev;
}

DEFUN(reverse, "reverse", (LispVal * list), "(list)", "") {
    LispVal *out = Qnil;
    DOLIST_SAFE(cur, list) {
        out = CONS(cur, out);
    }
    return out;
}

DEFUN(append, "append", (LispVal * lists), "(&rest lists)", "") {
    LispVal *out = Qnil;
    LispVal *end = Qnil;
    DOTAILS(rest, lists) {
        LispVal *cur = XCAR(rest);
        CHECK_LISTP(cur);
        if (NILP(cur)) {
            continue;
        }
        if (!NILP(XCDR(rest))) {
            cur = Fcopy_list(cur);
        }
        if (NILP(out)) {
            out = cur;
        } else {
            RPLACD(end, cur);
        }
        if (!NILP(XCDR(rest))) {
            end = Flast(cur);
            if (!NILP(XCDR(end))) {
                signal_type_error(cur, Qlist);
            }
        }
    }
    return out;
}

DEFUN(nconc, "nconc", (LispVal * lists), "(&rest lists)", "") {
    LispVal *out = Qnil;
    LispVal *end = Qnil;
    DOTAILS(rest, lists) {
        LispVal *cur = XCAR(rest);
        CHECK_LISTP(cur);
        if (NILP(cur)) {
            continue;
        }
        if (NILP(out)) {
            out = cur;
            end = Flast(cur);
        } else {
            RPLACD(end, cur);
            end = Flast(cur);
        }
        if (!NILP(XCDR(end)) && !NILP(XCDR(rest))) {
            signal_type_error(cur, Qlist);
        }
    }
    return out;
}

DEFUN(last, "last", (LispVal * list), "(list)", "") {
    if (NILP(list)) {
        return Qnil;
    }
    CHECK_LISTP(list);
    while (CONSP(XCDR(list))) {
        list = XCDR(list);
    }
    return list;
}

DEFUN(listp, "listp", (LispVal * obj), "(obj)", "") {
    return LISTP(obj) ? Qt : Qnil;
}

DEFUN(proper_list_p, "proper-list-p", (LispVal * obj), "(obj)", "") {
    CHECK_LISTP(obj);
    return (NILP(Fcircular_list_p(obj)) && NILP(XCDR(Flast(obj)))) ? Qt : Qnil;
}

DEFUN(circular_list_p, "circular-list-p", (LispVal * obj), "(obj)", "") {
    CHECK_LISTP(obj);
    return list_length(obj) == -1 ? Qt : Qnil;
}

DEFUN(dotted_list_p, "dotted-list-p", (LispVal * obj), "(obj)", "") {
    CHECK_LISTP(obj);
    return (NILP(Fcircular_list_p(obj)) && !NILP(XCDR(Flast(obj)))) ? Qt : Qnil;
}

DEFUN(list, "list", (LispVal * args), "(&rest args)", "") {
    return args;
}

DEFUN(list_star, "list*", (LispVal * arg, LispVal *args), "(arg &rest args)",
      "") {
    if (NILP(args)) {
        return arg;
    } else if (NILP(XCDR(args))) {
        return CONS(arg, XCAR(args));
    }
    LispVal *out = CONS(arg, args);
    args = out;
    while (CONSP(args) && CONSP(XCDR(args)) && CONSP(XCDR(XCDR(args)))) {
        args = XCDR(args);
    }
    RPLACD(args, XCAR(XCDR(args)));
    return out;
}

DEFUN(copy_list, "copy-list", (LispVal * list), "(list)", "") {
    LispVal *start = Qnil;
    LispVal *end = NULL;
    DOTAILS(rest, list) {
        if (!CONSP(rest)) {
            RPLACD(end, rest);
            break;
        }
        if (NILP(start)) {
            start = CONS(XCAR(rest), Qnil);
            end = start;
        } else {
            RPLACD(end, CONS(XCAR(rest), Qnil));
            end = XCDR(end);
        }
    }
    return start;
}

LispVal *nth(size_t n, LispVal *list) {
    size_t i = 0;
    DOLIST_SAFE(elt, list) {
        if (i == n) {
            return elt;
        }
        ++i;
    }
    return Qnil;
}

DEFUN(nth, "nth", (LispVal * n, LispVal *list), "(n list)", "") {
    CHECK_TYPE(n, TYPE_FIXNUM);
    return nth(XFIXNUM(n), list);
}

DEFUN(memq, "memq", (LispVal * elt, LispVal *list), "(elt list)", "") {
    DOTAILS(rest, list) {
        CHECK_LISTP(rest);
        if (elt == XCAR(rest)) {
            return rest;
        }
    }
    return Qnil;
}

DEFUN(member_if, "member-if", (LispVal * pred, LispVal *list), "(pred list)",
      "") {
    DOTAILS(rest, list) {
        CHECK_LISTP(rest);
        if (!NILP(CALL(pred, XCAR(rest)))) {
            return rest;
        }
    }
    return Qnil;
}

DEFUN(plist_put, "plist-put", (LispVal * plist, LispVal *prop, LispVal *value),
      "(plist prop value)", "") {
    LispVal *rest = plist;
    while (!NILP(rest)) {
        CHECK_LISTP(rest);
        CHECK_TYPE(XCDR(rest), TYPE_CONS);
        if (EQ(XCAR(rest), prop)) {
            RPLACA(XCDR(rest), value);
            return plist;
        }
        rest = XCDR(XCDR(rest));
    }
    return CONS(prop, CONS(value, plist));
}

DEFUN(plist_get, "plist-get", (LispVal * plist, LispVal *prop, LispVal *def),
      "(plist prop &optional default)", "") {
    while (!NILP(plist)) {
        CHECK_LISTP(plist);
        CHECK_TYPE(XCDR(plist), TYPE_CONS);
        if (EQ(XCAR(plist), prop)) {
            return SECOND(plist);
        }
        plist = XCDR(XCDR(plist));
    }
    return def;
}

DEFUN(assoc, "assoc", (LispVal * key, LispVal *alist, LispVal *pred),
      "(key alist &optional pred)", "") {
    if (NILP(pred)) {
        DOLIST_SAFE(ent, alist) {
            CHECK_TYPE(ent, TYPE_CONS);
            if (EQ(key, XCAR(ent))) {
                return ent;
            }
        }
        return Qnil;
    } else {
        DOLIST_SAFE(ent, alist) {
            CHECK_TYPE(ent, TYPE_CONS);
            if (!NILP(CALL(pred, key, XCAR(ent)))) {
                return ent;
            }
        }
        return Qnil;
    }
}