path: root/lith.c

/* lith: a small interpreter written in C89: as a library */
#include "lith.h"

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

static void *emalloc(lith_st *L, size_t len)
{
    void *p;
    p = malloc(len);
    if (!p) {
        L->error = LITH_ERR_NOMEM;
    }
    return p;
}

static char *lith__strndup(lith_st *L, char *str, size_t len)
{
    char *newstr, *p;
    newstr = emalloc(L, len + 1);
    if (!newstr) return NULL;
    p = newstr;
    while (len--) *p++ = *str++;
    *p = '\0';
    return newstr;
}

static void print_string(lith_string string, FILE *file)
{
    size_t i;
    char *s;
    s = string.buf;
    fputc('"', file);
    for (i = 0; i < string.len; s++, i++) {
        if ((*s == '\\') || (*s == '"')) {
            fputc('\\', file);
            fputc(*s, file);
        } else if (*s == '\n') {
            fprintf(file, "\\n");
        } else if (*s == '\t') {
            fprintf(file, "\\t");
        } else if (*s == '\0') {
            fprintf(file, "\\0");
        } else if ((*s < 32) || (*s > 126)) {
            fprintf(file, "\\x%02X", (unsigned char)(*s));
        } else {
            fputc(*s, file);
        }
    }
    fputc('"', file);
}

static char *skip(lith_st *L, char *input)
{
    size_t len;
    while (*input) {
        if ((len = strspn(input, " \t\n")) > 0) {
            input += len;
        } else if (*input == ';') {
            if (!(input = strchr(input, '\n')))
                break;
        } else { break; }
    }
    if (!input || !*input) {
        L->error = LITH_ERR_EOF;
    }
    return input;
}

static int ishexchar(int c)
{
    return (('0' <= c) && (c <= '9'))
        || (('a' <= c) && (c <= 'f'))
        || (('A' <= c) && (c <= 'F'));
}

static void eat_string(lith_st *L, char *start, char **end)
{
    for (*end = start; **end && (**end != '"'); ++*end) {
        if (**end == '\\') {
            ++*end;
            if (**end == 'x') {
                if (!((ishexchar(*++*end) && ishexchar(*++*end)))) {
                    lith_simple_error(L, LITH_ERR_SYNTAX,
                        "Invalid character escape literal, "
                        "expecting two hexadecimal characters");
                    return;
                }
            }
        }
    }
    if (!**end) {
        lith_simple_error(L, LITH_ERR_EOF, "while reading a string literal");
    } else {
        /* skip the string ending " character */
        ++*end;
    }
}

static void lex(lith_st *L, char *input, char **start, char **end)
{
    if (!(input = skip(L, input))) { *start = *end = NULL; return; }
    *start = input;
    if ((*input == '(') || (*input == ')') || (*input == '\'')
    || (*input == '@') || (*input == '`')) {
        *end = input + 1;
    } else if (*input == ',') {
        *end = input + ((input[1] == '@') ? 2 : 1);
    } else if (*input == '"') {
        /* +1 to skip the string starting " character */
        eat_string(L, *start + 1, end);
    } else {
        *end = *start + strcspn(*start, " \t\n;()");
    }
}

static char *read_string(lith_st *L, char *start, char *end, size_t *len)
{
    char *string, *p;
    p = string = emalloc(L, end - start);
    if (!p) return NULL;
    for (start++; start < end; start++, p++) {
        if (*start == '\\') {
            switch (*++start) {
            case 'n': *p = '\n'; break;
            case 'r': *p = '\r'; break;
            case 't': *p = '\t'; break;
            case '0': *p = '\0'; break;
            case 'x':
                *p = (char) strtol(++start, NULL, 16);
                ++start;
                break;
            default: *p = *start; break;
            }
        } else {
            *p = *start;
        }
    }
    *len = p - string;
    return string;
}

static lith_value *read_atom(lith_st *L, char *start, char *end)
{
    char *string, *next;
    int sign;
    size_t length;
    long integer;
    double number;
    lith_value *val;
    
    if (*start == '"') {
        /* -1 to skip the string ending " character */
        string = read_string(L, start, end - 1, &length);
        if (LITH_IS_ERR(L)) return NULL; 
        val = lith_make_string(L, string, length);
        free(string);
        return val;
    }
    if ((*start == '#') && ((end - start) == 2)
    && ((start[1] == 't') || (start[1] == 'f'))) {
        return (start[1] == 'f') ? L->False : L->True;
    }
    sign = (*start == '-') ? -1 : 1;
    integer = strtol(start, &next, 10);
    if (*next == '.') {
        number = strtod(next, &next);
        number *= sign;
        number += integer;
        return lith_make_number(L, number);
    } else if (next == end) {
        return lith_make_integer(L, integer);
    } else {
        string = lith__strndup(L, start, end - start);
        if (!string) return NULL;
        val = lith_get_symbol(L, string);
        free(string);
        return val;
    }
}

static lith_value *read_expr(lith_st *L, char *start, char **end);

static lith_value *read_list_expr(lith_st *L, char *start, char **end)
{
    lith_value *p, *expr, *list;
    char *t;
    *end = start;
    list = p = L->nil;
    for (;;) {
        lex(L, *end, &t, end);
        if (LITH_IS_ERR(L)) {
            if (LITH_AT_END_NO_ERR(L))
                lith_simple_error(L, LITH_ERR_EOF,
                    "while reading a list");
            return NULL;
        }
        if (*t == ')') return list;
        if (*t == '.' && (*end - t == 1)) {
            if (LITH_IS_NIL(p)) {
                lith_simple_error(L, LITH_ERR_SYNTAX,
                    "improper lists do not start with '.'");
                lith_free_value(list);
                return NULL;
            }
            expr = read_expr(L, *end, end);
            if (LITH_IS_ERR(L)) {
                 lith_free_value(list);
                 return NULL;
            }
            LITH_CDR(p) = expr;
            lex(L, *end, &t, end);
            if (LITH_IS_ERR(L) || (*t != ')')) {
                lith_simple_error(L, LITH_ERR_SYNTAX,
                    "expecting ')' at the end of this improper list");
                lith_free_value(list);
                return NULL;
            }
            return list;
        }
        expr = read_expr(L, t, end);
        if (LITH_IS_ERR(L)) {
            lith_free_value(list);
            return NULL;
        }
        if (LITH_IS_NIL(p)) {
            list = LITH_CONS(L, expr, L->nil);
            p = list;
        } else {
            LITH_CDR(p) = LITH_CONS(L, expr, L->nil);
            p = LITH_CDR(p);
        }
    }
}

static lith_value *read_expr(lith_st *L, char *start, char **end)
{
    lith_value *p, *q, *v;
    char *t, *s;
    lex(L, start, &t, end);
    if (LITH_IS_ERR(L)) return NULL;
    if (*t == '(') {
        return read_list_expr(L, *end, end);
    } else if (*t == ')') {
        lith_simple_error(L, LITH_ERR_SYNTAX,
            "unbalanced parenthesis, expected an expression");
        return NULL;
    } else if ((*t == '\'') || (*t == '@') || (*t == ',') || (*t == '`')) {
        if (*t == '\'')
            s = "quote";
        else if ((*t == '@') || (*t == '`'))
            s = "quasiquote";
        else if (*t == ',')
            s = (t[1] == '@')
                ? "unquote-splicing"
                : "unquote";
        p = LITH_CONS(L, lith_get_symbol(L, s), L->nil);
        v = read_expr(L, *end, end);
        if (!v) { lith_free_value(p); return NULL; }
        q = LITH_CONS(L, v, L->nil);
        if (!q) { lith_free_value(v); lith_free_value(p); return NULL; }
        LITH_CDR(p) = q;
        return p;
    } else {
        return read_atom(L, t, *end);
    }
}

static int is_proper_list(lith_value *list)
{
    while (!LITH_IS_NIL(list)) {
        list = LITH_CDR(list);
        if (!(LITH_IS_NIL(list) || LITH_IS(list, LITH_TYPE_PAIR))) {
            return 0;
        }
    }
    return 1;
}

static size_t list_length(lith_value *v)
{
    size_t len;
    for (len = 0; !LITH_IS_NIL(v); len++) v = LITH_CDR(v);
    return len;
}

/* builtin functions of lith */

/* car[1] :: (car '(a . b)) -> a */
static lith_value *builtin__car(lith_st *L, lith_value *args)
{
    lith_value *list;
    list = LITH_CAR(args);
    if (!lith_expect_type(L, "car", 1, LITH_TYPE_PAIR, list)) return NULL;
    return LITH_CAR(list);
}

/* cdr[1] :: (cdr '(a . b)) -> b */
static lith_value *builtin__cdr(lith_st *L, lith_value *args)
{
    lith_value *pair;
    pair = LITH_CAR(args);
    if (!lith_expect_type(L, "cdr", 1, LITH_TYPE_PAIR, pair)) return NULL;
    return LITH_CDR(pair);
}

/* cons[2] :: (cons a b) -> (a . b) */
static lith_value *builtin__cons(lith_st *L, lith_value *args)
{
    lith_value *head, *tail;
    head = LITH_CAR(args);
    tail = LITH_CAR(LITH_CDR(args));
    return LITH_CONS(L, head, tail);
}

static void lith__print(lith_st *L, lith_value *v)
{
    if (LITH_IS(v, LITH_TYPE_STRING)) {
        fwrite(v->value.string.buf, 1, v->value.string.len, stdout);
    } else {
        lith_print_value(L, v, stdout);
    }
}

/* print[1+] ::
 * (print ...) -> ()
 * and prints the values
 * separated by ' '
 * and a newline ('\n')
 */
static lith_value *builtin__print(lith_st *L, lith_value *args)
{
    lith_value *v;
    v = args;
    lith__print(L, LITH_CAR(v));
    v = LITH_CDR(v);
    while (!LITH_IS_NIL(v)) {
        putchar(' ');
        lith__print(L, LITH_CAR(v));
        v = LITH_CDR(v);
    }
    putchar('\n');
    return L->nil;
}

#define COMMON1(fname) \
    int n1_is_integer, n1_is_number, \
        n2_is_integer, n2_is_number, \
        n1_is_numeric, n2_is_numeric; \
    lith_value *arg1, *arg2; \
    arg1 = LITH_CAR(args); \
    arg2 = LITH_CAR(LITH_CDR(args)); \
    n1_is_integer = LITH_IS(arg1, LITH_TYPE_INTEGER); \
    n1_is_number = LITH_IS(arg1, LITH_TYPE_NUMBER); \
    n1_is_numeric = n1_is_integer || n1_is_number; \
    n2_is_integer = LITH_IS(arg2, LITH_TYPE_INTEGER); \
    n2_is_number = LITH_IS(arg2, LITH_TYPE_NUMBER); \
    n2_is_numeric = n2_is_integer || n2_is_number; \
    if (!n1_is_numeric || !n2_is_numeric) { \
        lith_simple_error(L, LITH_ERR_TYPE, \
            "expected numeric types (integers or numbers) as argument"); \
        return NULL; \
    }

#define COMMON2(op) \
    if (n1_is_integer && n2_is_integer) { \
        return lith_make_integer(L, arg1->value.integer op arg2->value.integer); \
    } else { \
        return lith_make_number(L, \
          (n1_is_integer \
            ? ((double) (arg1->value.integer)) \
            : arg1->value.number) \
          op \
          (n2_is_integer \
            ? ((double) (arg2->value.integer)) \
            : arg2->value.number)); \
    }

/* op1[2] ::: op1 <- (:+), (:-), (:*)
 * (op1 int int) -> int
 * (op1 int num) -> num
 * (op1 num int) -> num
 * (op1 num num) -> num
 */

static lith_value *builtin__add(lith_st *L, lith_value *args)
{
    COMMON1(":+")
    COMMON2(+)
}

static lith_value *builtin__subtract(lith_st *L, lith_value *args)
{
    COMMON1(":-")
    COMMON2(-)
}

static lith_value *builtin__multiply(lith_st *L, lith_value *args)
{
    COMMON1(":*")
    COMMON2(*)
}

#define COMMON3(op, q) \
    if (q && (arg2->value.integer == 0L)) { \
        lith_simple_error(L, LITH_ERR_TYPE, "cannot " op " by zero!!"); \
        return NULL; \
    }

/* type int_n0 = int \ {0} ; hah!
 * :/[2] ::
 * (:/ int int_n0) -> int
 * (:/ int num) -> num
 * (:/ num int) -> num
 * (:/ num num) -> num
 */

static lith_value *builtin__divide(lith_st *L, lith_value *args)
{
    COMMON1(":/")
    COMMON3("divide", n2_is_integer)
    COMMON2(/)
}

/* :%[2] (:% int int) -> int */
static lith_value *builtin__modulus(lith_st *L, lith_value *args)
{
    lith_value *arg1, *arg2;
    arg1 = LITH_CAR(args);
    arg2 = LITH_CAR(LITH_CDR(args));
    if (!LITH_IS(arg1, LITH_TYPE_INTEGER) || !LITH_IS(arg2, LITH_TYPE_INTEGER)) {
        lith_simple_error(L, LITH_ERR_TYPE, "can calculate modulus with integral arguments only");
        return NULL;
    }
    COMMON3("mod", 1)
    return lith_make_integer(L, arg1->value.integer % arg2->value.integer);
}

#define COMMON4(op) \
    if (n1_is_integer && n2_is_integer) { \
        return LITH_IN_BOOL(arg1->value.integer op arg2->value.integer); \
    } else { \
        return LITH_IN_BOOL( \
          (n1_is_integer \
            ? ((double) (arg1->value.integer)) \
            : arg1->value.number) \
          op \
          (n2_is_integer \
            ? ((double) (arg2->value.integer)) \
            : arg2->value.number) \
        ); \
    }

/* type numeric = int U num ; huh!
 * op2[2] :: op2 <- (:<, :==, :>)
 * (op2 numeric numeric) -> bool
 */

static lith_value *builtin__is_less_than(lith_st *L, lith_value *args)
{
    COMMON1(":<")
    COMMON4(<)
}

static lith_value *builtin__is_num_equal(lith_st *L, lith_value *args)
{
    COMMON1(":==")
    COMMON4(==)
}

static lith_value *builtin__is_greater_than(lith_st *L, lith_value *args)
{
    COMMON1(":>")
    COMMON4(>)
}

#undef COMMON4
#undef COMMON3
#undef COMMON2
#undef COMMON1

/* eq?[2] :: (eq? a b) -> bool */
static lith_value *builtin__is_eq(lith_st *L, lith_value *args)
{
    int eq;
    lith_value *arg1, *arg2;
    arg1 = LITH_CAR(args);
    arg2 = LITH_CAR(LITH_CDR(args));
    if (arg1->type != arg2->type) return L->False;
    switch (arg1->type) {
    case LITH_TYPE_NIL:
        return L->True;
    case LITH_TYPE_INTEGER:
        eq = arg1->value.integer == arg2->value.integer; break;
    case LITH_TYPE_NUMBER:
        eq = arg1->value.number == arg2->value.number; break;
    case LITH_TYPE_STRING:
        if (arg1->value.string.len != arg2->value.string.len) return L->False;
        eq = !memcmp(arg1->value.string.buf, 
            arg2->value.string.buf, arg2->value.string.len);
        break;
    default: eq = arg1 == arg2; break;
    }
    return LITH_IN_BOOL(eq);
}

/* typeof[1] :: (typeof a) -> sym */
static lith_value *builtin__typeof(lith_st *L, lith_value *args)
{
    lith_value *val;
    val = LITH_CAR(args);
    return lith_get_symbol(L, L->types[val->type]);
}

/* nil?[1] :: (nil? a) -> bool */
static lith_value *builtin__is_nil(lith_st *L, lith_value *args)
{
    return LITH_IN_BOOL(LITH_IS_NIL(LITH_CAR(args)));
}

/* list?[1] :: (list? a) -> bool */
static lith_value *builtin__is_list(lith_st *L, lith_value *args)
{
    lith_value *val;
    val = LITH_CAR(args);
    return LITH_IN_BOOL(LITH_IS(val, LITH_TYPE_PAIR)
        && is_proper_list(val));
}

/* apply[2] :: (apply (i... -> a) (i...)) -> a */
static lith_value *builtin__apply(lith_st *L, lith_value *args)
{
    lith_value *f, *aargs, *cargs;
    f = LITH_CAR(args);
    aargs = LITH_CAR(LITH_CDR(args));
    cargs = lith_copy_value(L, aargs);
    if (!cargs) return NULL;
    return lith_apply(L, f, cargs);
}

/* error[1] :: (error str) -> _|_ */
static lith_value *builtin__error(lith_st *L, lith_value *args)
{
    lith_value *arg;
    arg = LITH_CAR(args);
    if (!lith_expect_type(L, "error", 1, LITH_TYPE_STRING, arg)) return NULL;
    L->error = LITH_ERR_CUSTOM;
    L->error_state.msg = arg->value.string.buf;
    return NULL;
}

/* load[1] :: (load str) -> ()
 * the contents of the file given by
 * the string containing the path of that file is executed
 */

static lith_value *builtin__load(lith_st *L, lith_value *args)
{
    lith_value *filename;
    filename = LITH_CAR(args);
    if (!lith_expect_type(L, "load", 1, LITH_TYPE_STRING, filename)) return NULL;
    lith_run_file(L, L->global, filename->value.string.buf);
    if (LITH_IS_ERR(L))
        return NULL;
    else
        return L->nil;
}

/* some more utilities */

static char *slurp(lith_st *L, char *filename)
{
    FILE *file;
    char *buffer;
    long length;
    
    file = fopen(filename, "r");
    if (!file) {
        lith_simple_error(L, LITH_ERR_CUSTOM, "could not open the file to be read");
        return NULL;
    }
    
    fseek(file, 0, SEEK_END);
    length = ftell(file);
    fseek(file, 0, SEEK_SET);
    
    buffer = emalloc(L, length + 1);
    if (!buffer) return NULL;
    
    fread(buffer, 1, length, file);
    buffer[length] = '\0';
    fclose(file);
    
    return buffer;
}

static void init_types(char **types)
{
    types[LITH_TYPE_NIL] = "nil";
    types[LITH_TYPE_PAIR] = "pair";
    types[LITH_TYPE_BOOLEAN] = "boolean";
    types[LITH_TYPE_INTEGER] = "integer";
    types[LITH_TYPE_NUMBER] = "number";
    types[LITH_TYPE_SYMBOL] = "symbol";
    types[LITH_TYPE_STRING] = "string";
    types[LITH_TYPE_BUILTIN] = "builtin";
    types[LITH_TYPE_CLOSURE] = "closure";
    types[LITH_TYPE_MACRO] = "macro";
}

struct lith_lib_fn lith_builtins[] = {
    {"car", 1, 1, builtin__car},
    {"cdr", 1, 1, builtin__cdr},
    {"cons", 2, 1, builtin__cons},
    {"typeof", 1, 1, builtin__typeof},
    {"print", 1, 0, builtin__print},
    {":+", 2, 1, builtin__add},
    {":-", 2, 1, builtin__subtract},
    {":*", 2, 1, builtin__multiply},
    {":/", 2, 1, builtin__divide},
    {":%", 2, 1, builtin__modulus},
    {":<", 2, 1, builtin__is_less_than},
    {":==", 2, 1, builtin__is_num_equal},
    {":>", 2, 1, builtin__is_greater_than},
    {"eq?", 2, 1, builtin__is_eq},
    {"nil?", 1, 1, builtin__is_nil},
    {"list?", 1, 1, builtin__is_list},
    {"apply", 2, 1, builtin__apply},
    {"error", 1, 1, builtin__error},
    {"load", 1, 1, builtin__load},
    {NULL, 0, 0, NULL}
};

/* Public functions */

void lith_init(lith_st *L)
{
    L->error = LITH_ERR_OK;
    L->error_state.manual = 0;
    L->error_state.success = 1;
    L->error_state.sym = L->error_state.msg = L->error_state.name = NULL;
    L->error_state.expr = NULL;
    L->nil = lith_new_value(L);
    L->nil->type = LITH_TYPE_NIL;
    L->True = lith_new_value(L);
    L->False = lith_new_value(L);
    L->True->type = L->False->type = LITH_TYPE_BOOLEAN;
    L->True->value.boolean = 1;
    L->False->value.boolean = 0;
    L->symbol_table = L->nil;
    L->global = lith_new_env(L, L->nil);
    L->global = lith_new_env(L, L->global);
    L->filename = "<<unspecified>>";
    init_types(L->types);
    lith_fill_env(L, lith_builtins);
}

void lith_free(lith_st *L)
{
    lith_value *p, *v;
    lith_free_value(L->global);
    p = L->symbol_table;
    while (!LITH_IS_NIL(p)) {
        v = LITH_CAR(p);
        free(v->value.symbol);
        free(v);
        p = LITH_CDR(p);
    }
    if (L->error_state.expr)
        lith_free_value(L->error_state.expr);
    free(L->False);
    free(L->True);
    free(L->nil);
}

void lith_clear_error_state(lith_st *L)
{
    L->error = LITH_ERR_OK;
    L->error_state.success = 1;
    L->error_state.manual = 0;
    L->error_state.msg = L->error_state.sym = L->error_state.name = NULL;
    if (L->error_state.expr) {
        lith_free_value(L->error_state.expr);
        L->error_state.expr = NULL;
    }
}

lith_value *lith_new_value(lith_st *L)
{
    return emalloc(L, sizeof(lith_value));
}

lith_value *lith_make_integer(lith_st *L, long integer)
{
    lith_value *val;
    val = lith_new_value(L);
    if (!val) return NULL;
    val->type = LITH_TYPE_INTEGER;
    val->value.integer = integer;
    return val;
}

lith_value *lith_make_number(lith_st *L, double number)
{
    lith_value *val;
    val = lith_new_value(L);
    if (!val) return NULL;
    val->type = LITH_TYPE_NUMBER;
    val->value.number = number;
    return val;
}

lith_value *lith_make_symbol(lith_st *L, char *symbol)
{
    lith_value *val;
    char *sym;
    val = lith_new_value(L);
    if (!val) return NULL;
    val->type = LITH_TYPE_SYMBOL;
    sym = lith__strndup(L, symbol, strlen(symbol));
    if (!sym) { free(val); return NULL; }
    val->value.symbol = sym;
    return val;
}

lith_value *lith_make_builtin(lith_st *L, lith_value *name, lith_builtin_function function,
                              size_t expect, int exact)
{
    lith_value *val;
    lith_callable *f;
    val = lith_new_value(L);
    if (!val) return NULL;
    f = emalloc(L, sizeof(*f));
    if (!f) { free(val); return NULL; }
    f->name = name;
    f->function = function;
    f->expect = expect;
    f->exact = exact;
    val->type = LITH_TYPE_BUILTIN;
    val->value.callable = f;
    return val;
}

lith_value *lith_make_closure(lith_st *L, lith_env *parent_env,
                              lith_value *name, lith_value *arg_names, lith_value *body,
                              size_t expect, int exact
)
{
    lith_value *val;
    lith_callable *f;
    val = lith_new_value(L);
    if (!val) return NULL;
    f = emalloc(L, sizeof(*f));
    if (!f) { free(val); return NULL; }
    arg_names = lith_copy_value(L, arg_names);
    if (!arg_names) { free(val); free(f); return NULL; }
    body = lith_copy_value(L, body);
    if (!body) { free(val); free(f); lith_free_value(arg_names); return NULL; }
    f->name = name;
    f->parent = parent_env;
    f->args = arg_names;
    f->body = body;
    f->expect = expect;
    f->exact = exact;
    val->type = LITH_TYPE_CLOSURE;
    val->value.callable = f;
    return val;
}

lith_value *lith_make_string(lith_st *L, char *string, size_t len)
{
    lith_value *val;
    char *str;
    val = lith_new_value(L);
    if (!val) return NULL;
    val->type = LITH_TYPE_STRING;
    str = lith__strndup(L, string, len);
    if (!str) { free(val); return NULL; }
    val->value.string.len = len;
    val->value.string.buf = str;
    return val; 
}

lith_value *lith_make_pair(lith_st *L, lith_value *car, lith_value *cdr)
{
    lith_value *val;
    val = lith_new_value(L);
    if (!val) return NULL;
    val->type = LITH_TYPE_PAIR;
    LITH_CAR(val) = car;
    LITH_CDR(val) = cdr;
    return val;
}

void lith_free_value(lith_value *val)
{
    if (LITH_IS(val, LITH_TYPE_PAIR)) {
        lith_free_value(LITH_CAR(val));
        lith_free_value(LITH_CDR(val));
    } else if (LITH_IS(val, LITH_TYPE_BUILTIN)) {
        free(val->value.callable);
    } else if (LITH_IS(val, LITH_TYPE_CLOSURE) || LITH_IS(val, LITH_TYPE_MACRO)) {
        lith_free_value(val->value.callable->args);
        lith_free_value(val->value.callable->body);
        free(val->value.callable);
    } else if (LITH_IS(val, LITH_TYPE_STRING)) {
        free(val->value.string.buf);
    } else if (LITH_IS_NIL(val) || LITH_IS(val, LITH_TYPE_BOOLEAN)
           ||  LITH_IS(val, LITH_TYPE_SYMBOL)) {
        return;
    }
    free(val);
}

lith_value *lith_get_symbol(lith_st *L, char *name)
{
    lith_value *sym, *p;
    p = L->symbol_table;
    while (!LITH_IS_NIL(p)) {
        sym = LITH_CAR(p);
        if (LITH_SYM_EQ(sym, name)) return sym;
        p = LITH_CDR(p);
    }
    sym = lith_make_symbol(L, name);
    if (!sym) return NULL;
    p = LITH_CONS(L, sym, L->symbol_table);
    if (!p) { lith_free_value(sym); return NULL; }
    L->symbol_table = p;
    return sym;
}

void lith_print_value(lith_st *L, lith_value *val, FILE *file)
{
    lith_callable *fn;
    if (LITH_IS_NIL(val)) {
        fprintf(file, "()");
    } else if (LITH_IS(val, LITH_TYPE_SYMBOL)) {
        fprintf(file, "%s", val->value.symbol);
    } else if (LITH_IS(val, LITH_TYPE_STRING)) {
        print_string(val->value.string, file);
    } else if (LITH_IS(val, LITH_TYPE_BOOLEAN)) {
        fprintf(file, "#%c", val->value.boolean ? 't' : 'f');
    } else if (LITH_IS(val, LITH_TYPE_INTEGER)) {
        fprintf(file, "%ld", val->value.integer);
    } else if (LITH_IS(val, LITH_TYPE_NUMBER)) {
        fprintf(file, "%.15g", val->value.number);
    } else if (LITH_IS_CALLABLE(val)) {
        fn = val->value.callable;
        fprintf(file, "#<%s ", L->types[val->type]);
        if (fn->name)
            lith_print_value(L, fn->name, file);
        else
            fprintf(file, "[anon]");
        fprintf(file, "[%zu%s]", fn->expect, fn->exact ? "" : "+");
        fprintf(file, " at %p>", (void *)fn);
    } else if (!LITH_IS(val, LITH_TYPE_PAIR)) {
        fprintf(file, "#<unknown object at %p>", (void *)val);
    } else {
        fputc('(', file);
        lith_print_value(L, LITH_CAR(val), file);
        val = LITH_CDR(val);
        while (!LITH_IS_NIL(val)) {
            if (LITH_IS(val, LITH_TYPE_PAIR)) {
                fputc(' ', file);
                lith_print_value(L, LITH_CAR(val), file);
                val = LITH_CDR(val);
            } else {
                fprintf(file, " . ");
                lith_print_value(L, val, file);
                break;
            }
        }
        fputc(')', file);
    }
}

lith_value *lith_copy_value(lith_st *L, lith_value *val)
{
    lith_value *head, *pair, *p, *v, *w;
    lith_callable *f;
    if (!val) return NULL;
    switch (val->type) {
    case LITH_TYPE_INTEGER:
        return lith_make_integer(L, val->value.integer);
    case LITH_TYPE_NUMBER:
        return lith_make_number(L, val->value.number);
    case LITH_TYPE_STRING:
        return lith_make_string(L, val->value.string.buf, val->value.string.len);
    case LITH_TYPE_BUILTIN:
        f = val->value.callable;
        return lith_make_builtin(L, lith_copy_value(L, f->name), f->function, f->expect, f->exact);
    case LITH_TYPE_MACRO:
    case LITH_TYPE_CLOSURE:
        f = val->value.callable;
        v = lith_make_closure(L, f->parent, lith_copy_value(L, f->name),
                f->args, f->body, f->expect, f->exact);
        if (LITH_IS(val, LITH_TYPE_MACRO))
            v->type = LITH_TYPE_MACRO;
        return v;
    case LITH_TYPE_PAIR:
        head = lith_copy_value(L, LITH_CAR(val));
        if (!head) return NULL;
        pair = LITH_CONS(L, head, L->nil);
        if (!pair) { lith_free_value(head); return NULL; }
        val = LITH_CDR(val);
        for (p = pair; LITH_IS(val, LITH_TYPE_PAIR);
            val = LITH_CDR(val), p = LITH_CDR(p)) {
            v = lith_copy_value(L, LITH_CAR(val));
            if (!v) { lith_free_value(pair); return NULL; }
            w = LITH_CONS(L, v, L->nil);
            if (!w) { lith_free_value(pair); lith_free_value(v); }
            LITH_CDR(p) = w;
        }
        if (!LITH_IS_NIL(val)) {
            v = lith_copy_value(L, val);
            if (!v) { lith_free_value(v); return NULL; }
            LITH_CDR(p) = v;
        }
        return pair;
    default: return val;
    }
}

void lith_simple_error(lith_st *L, enum lith_error errtype, char *msg)
{
    L->error = errtype;
    L->error_state.msg = msg;
    if (errtype == LITH_ERR_EOF)
        L->error_state.success = 0;
    else if (errtype == LITH_ERR_TYPE)
        L->error_state.manual = 1;
}

void lith_print_error(lith_st *L, int full)
{
    struct lith_error_state E = L->error_state;
    if (full) fprintf(stderr, "lith: %s: ", L->filename);
    switch (L->error) {
    case LITH_ERR_OK:
        fprintf(stderr, "none");
        break;
    case LITH_ERR_EOF:
        if (!E.success) fprintf(stderr, "Unexpected ");
        fprintf(stderr, "End of File");
        if (!E.success) fprintf(stderr, ": %s", E.msg);
        break;
    case LITH_ERR_SYNTAX:
        fprintf(stderr, "syntax error: %s", E.msg);
        break;
    case LITH_ERR_NOMEM:
        fprintf(stderr, "out of memory");
        break;
    case LITH_ERR_UNBOUND:
        fprintf(stderr, "unbound symbol: '%s'", E.sym);
        break;
    case LITH_ERR_REDEFINE:
        fprintf(stderr, "trying to redefine already defined symbol: '%s'", E.sym);
        break;
    case LITH_ERR_NARGS:
        fprintf(stderr, "wrong number of arguments: "
            "expected %s%zu argument(s) but given %zu argument(s)",
            (E.nargs.exact ? "" : "at least "),
            E.nargs.expected, E.nargs.got);
        break;
    case LITH_ERR_TYPE:
        fprintf(stderr, "type error: ");
        if (E.manual)
            fprintf(stderr, "%s", E.msg);
        else
            fprintf(stderr, "expecting %s instead of %s as the argument number %zu",
                L->types[E.type.expected],
                L->types[E.type.got], E.type.narg);
        break;
    case LITH_ERR_CUSTOM:
        fprintf(stderr, "error: %s", E.msg);
        break;
    }
    if (E.name)
        fprintf(stderr, " [in '%s']", E.name);
    if (E.expr) {
        fprintf(stderr, "\noccured in: ");
        lith_print_value(L, E.expr, stderr);
    }
    fputc('\n', stderr);
}

lith_value *lith_read_expr(lith_st *L, char *start, char **end)
{
    return read_expr(L, start, end);
}

lith_env *lith_new_env(lith_st *L, lith_env *parent)
{
    return LITH_CONS(L, parent, L->nil);
}

void lith_free_env(lith_env *V)
{
    lith_free_value(LITH_CDR(V));
}

lith_value *lith_env_get(lith_st *L, lith_env *V, lith_value *name)
{
    lith_env *parent;
    lith_value *kvs, *kv;
    parent = V;
    do {
        kvs = LITH_CDR(parent);
        parent = LITH_CAR(parent);
        while (!LITH_IS_NIL(kvs)) {
            kv = LITH_CAR(kvs);
            if (LITH_CAR(kv) == name)
                return LITH_CDR(kv);
            kvs = LITH_CDR(kvs);
        }
    } while (!LITH_IS_NIL(parent));
    L->error = LITH_ERR_UNBOUND;
    L->error_state.sym = name->value.symbol;
    return NULL;
}

void lith_env_set(lith_st *L, lith_env *V, lith_value *name, lith_value *value)
{
    lith_env *parent;
    lith_value *kvs, *kv;
    parent = V;
    do {
        kvs = LITH_CDR(parent);
        parent = LITH_CAR(parent);
        while (!LITH_IS_NIL(kvs)) {
            kv = LITH_CAR(kvs);
            if (LITH_CAR(kv) == name) {
                LITH_CDR(kv) = value;
                return;
            }
            kvs = LITH_CDR(kvs);
        }
    } while (!LITH_IS_NIL(parent));
    L->error = LITH_ERR_UNBOUND;
    L->error_state.sym = name->value.symbol;
}

void lith_env_put(lith_st *L, lith_env *V, lith_value *name, lith_value *value)
{
    lith_value *kvs, *kv;
    kvs = LITH_CDR(V);
    while (!LITH_IS_NIL(kvs)) {
        kv = LITH_CAR(kvs);
        if (name == LITH_CAR(kv)) {
            L->error = LITH_ERR_REDEFINE;
            L->error_state.sym = name->value.symbol;
            return;
        }
        kvs = LITH_CDR(kvs);
    }
    kv = LITH_CONS(L, name, value);
    if (!kv) return;
    LITH_CDR(V) = LITH_CONS(L, kv, LITH_CDR(V));
}

void lith_fill_env(lith_st *L, lith_lib lib)
{
    lith_env *V;
    lith_value *name;
    struct lith_lib_fn *fns;
    V = L->global;
    for (fns = lib; fns->name; ++fns) {
        name = lith_get_symbol(L, fns->name);
        if (!name) return;
        lith_env_put(L, V, name,
            lith_make_builtin(L, name, fns->fn, fns->expect, fns->exact));
    }
}

int lith_expect_nargs(lith_st *L, char *name, size_t expect,
                      lith_value *args, int exact)
{
    size_t len;
    struct lith_error_state *E;
    E = &L->error_state;
    len = list_length(args);
    if (exact ? (len != expect) : (len < expect)) {
        L->error = LITH_ERR_NARGS;
        E->name = name;
        E->nargs.expected = expect;
        E->nargs.exact = exact;
        E->nargs.got = len;
        E->expr = lith_copy_value(L, args);
        return 0;
    } else {
        return 1;
    }
}

int lith_expect_type(lith_st *L, char *name, size_t narg,
                     lith_valtype type, lith_value *val)
{
    struct lith_error_state *E;
    E = &L->error_state;
    if (LITH_IS(val, type))
        return 1;
    L->error = LITH_ERR_TYPE;
    E->name = name;
    E->type.expected = type;
    E->type.got = val->type;
    E->type.narg = narg;
    E->expr = lith_copy_value(L, val);
    return 0;
}

lith_value *lith_eval_expr(lith_st *L, lith_env *V, lith_value *expr)
{
    size_t i;
    lith_value *f, *rest, *sym, *val, *args, *p, *q, *r;
    if (LITH_IS(expr, LITH_TYPE_SYMBOL)) {
        return lith_copy_value(L, lith_env_get(L, V, expr));
    } else if (!LITH_IS(expr, LITH_TYPE_PAIR)) {
        return lith_copy_value(L, expr);
    } else if (!is_proper_list(expr)) {
        lith_simple_error(L, LITH_ERR_SYNTAX, 
            "atom or proper list expected as expression");
        return NULL;
    }
    f = LITH_CAR(expr);
    rest = LITH_CDR(expr);
    if (LITH_IS(f, LITH_TYPE_SYMBOL)) {
        if (LITH_SYM_EQ(f, "quote")) {
            if (!lith_expect_nargs(L, "quote", 1, rest, 1))
                return NULL;
            return lith_copy_value(L, LITH_CAR(rest));
        } else if (LITH_SYM_EQ(f, "eval!")) {
            if (!lith_expect_nargs(L, "eval!", 1, rest, 1))
                return NULL;
            val = lith_eval_expr(L, V, LITH_CAR(rest));
            if (!val) return NULL;
            return lith_eval_expr(L, V, val); 
        } else if (LITH_SYM_EQ(f, "if")) {
            if (!lith_expect_nargs(L, "if", 3, rest, 1)) return NULL;
            val = lith_eval_expr(L, V, LITH_CAR(rest));
            if (LITH_IS_ERR(L)) return NULL;
            p = LITH_CDR(rest);
            return lith_eval_expr(L, V, LITH_CAR(LITH_TO_BOOL(val) ? p : LITH_CDR(p)));
        } else if (LITH_SYM_EQ(f, "def")) {
            if (!lith_expect_nargs(L, "def", 2, rest, 1))
                return NULL;
            sym = LITH_CAR(rest);
            p = LITH_CDR(rest);
            if (!lith_expect_type(L, "def", 1, LITH_TYPE_SYMBOL, sym)) return NULL;
            val = lith_eval_expr(L, V, LITH_CAR(p));
            if (LITH_IS_CALLABLE(val))
                val->value.callable->name = sym;
            if (!val) return NULL;
            lith_env_put(L, V, sym, val);
            return L->nil;
        } else if (LITH_SYM_EQ(f, "set!")) {
            if (!lith_expect_nargs(L, "set!", 2, rest, 1))
                return NULL;
            sym = LITH_CAR(rest);
            val = LITH_CAR(LITH_CDR(rest));
            if (!lith_expect_type(L, "set!", 1, LITH_TYPE_SYMBOL, sym))
                return NULL;
            val = lith_eval_expr(L, V, val);
            if (!val) return NULL;
            lith_env_set(L, V, sym, val);
            if (LITH_IS_CALLABLE(val))
                val->value.callable->name = sym;
            return L->nil;
        } else if (LITH_SYM_EQ(f, "macro")) {
            if (!lith_expect_nargs(L, "macro", 2, rest, 0))
                return NULL;
            args = LITH_CAR(rest);
            p = LITH_CDR(rest);
            if (!lith_expect_type(L, "macro", 1, LITH_TYPE_PAIR, args))
                return NULL;
            sym = LITH_CAR(args);
            if (!lith_expect_type(L, "macro", 1, LITH_TYPE_SYMBOL, sym))
                return NULL;
            q = LITH_CONS(L, LITH_CDR(args), p);
            if (!q) return NULL;
            r = LITH_CONS(L, lith_get_symbol(L, "lambda"), q);
            if (!r) { lith_free_value(q); return NULL; }
            val = lith_eval_expr(L, V, r);
            if (!val) return NULL;
            val->type = LITH_TYPE_MACRO;
            val->value.callable->name = sym;
            lith_env_put(L, V, sym, val);
            return L->nil;
        } else if (LITH_SYM_EQ(f, "lambda")) {
            if (!lith_expect_nargs(L, "{lambda}", 2, rest, 0))
                return NULL;
            args = LITH_CAR(rest);
            p = LITH_CDR(rest);
            if (!is_proper_list(p)) {
                lith_simple_error(L, LITH_ERR_SYNTAX,
                    "body of lambda expression must be proper list");
                return NULL;
            }
            for (i = 0, q = args; LITH_IS(q, LITH_TYPE_PAIR); q = LITH_CDR(q), i++) {
                if (!LITH_IS(LITH_CAR(q), LITH_TYPE_SYMBOL)) {
                    lith_simple_error(L, LITH_ERR_SYNTAX,
                        "arguments in lambda expression must be symbols");
                    return NULL;
                }
            }
            if (!LITH_IS_NIL(q) && !LITH_IS(q, LITH_TYPE_SYMBOL)) {
                lith_simple_error(L, LITH_ERR_SYNTAX,
                    "arguments in lambda expression must be symbols");
                return NULL;
            }
            return lith_make_closure(L, V, NULL, args, p, i, LITH_IS_NIL(q));
        }
    }
    f = lith_eval_expr(L, V, f);
    if (!f) return NULL;
    args = lith_copy_value(L, rest);
    if (!args) return NULL;
    if (LITH_IS(f, LITH_TYPE_MACRO)) {
        val = lith_apply(L, f, args);
        if (!val) return NULL;
        return lith_eval_expr(L, V, val);
    }
    if (!LITH_IS_NIL(args)) {
        rest = args;
        val = lith_eval_expr(L, V, LITH_CAR(rest));
        if (!val) return NULL;
        args = LITH_CONS(L, val, L->nil);
        if (!args) { lith_free_value(val); return NULL; }
        rest = LITH_CDR(rest);
        for (p = args; !LITH_IS_NIL(rest); p = LITH_CDR(p), rest = LITH_CDR(rest)) {
            val = lith_eval_expr(L, V, LITH_CAR(rest));
            if (!val) { lith_free_value(args); return NULL; }
            q = LITH_CONS(L, val, L->nil);
            if (!q) { lith_free_value(args); lith_free_value(val); return NULL; }
            LITH_CDR(p) = q;
        }
    }
    return lith_apply(L, f, args);
}

lith_value *lith_apply(lith_st *L, lith_value *f, lith_value *args)
{
    lith_env *env;
    lith_value *expected_args, *body, *r;
    lith_callable *fn;
    
    if (!LITH_IS_CALLABLE(f)) {
        lith_simple_error(L, LITH_ERR_TYPE, "can not call non-callable");
        L->error_state.name = "{apply}";
        return NULL;
    }
    fn = f->value.callable;
    if (!lith_expect_nargs(L,
        fn->name ? fn->name->value.symbol : "{lambda}",
        fn->expect, args, fn->exact)) return NULL;
    if (LITH_IS(f, LITH_TYPE_BUILTIN))
        return (*fn->function)(L, args);
    env = lith_new_env(L, fn->parent);
    body = fn->body;
    expected_args = fn->args;
    while (LITH_IS(expected_args, LITH_TYPE_PAIR)) {
        lith_env_put(L, env, LITH_CAR(expected_args), LITH_CAR(args));
        expected_args = LITH_CDR(expected_args);
        args = LITH_CDR(args);
    }
    if (!LITH_IS_NIL(expected_args))
        lith_env_put(L, env, expected_args, args);
    r = NULL;
    while (!LITH_IS_NIL(body)) {
        if (r) lith_free_value(r);
        r = lith_eval_expr(L, env, LITH_CAR(body));
        body = LITH_CDR(body);
    }
    return r;
}

void lith_run_string(lith_st *L, lith_env *V, char *input, int repl)
{
    char *end;
    lith_value *expr, *res;
    end = input;
    L->filename = repl ? "<<stdin>>" : "<<string>>";
    
    while (!LITH_IS_ERR(L)) {
        if ((expr = lith_read_expr(L, end, &end))) {
            if (!repl) {
                printf(">> ");
                lith_print_value(L, expr, stdout);
                putchar('\n');
            }
            if ((res = lith_eval_expr(L, V, expr))) {
                printf("-> ");
                lith_print_value(L, res, stdout);
                lith_free_value(res);
                putchar('\n');
            }
            lith_free_value(expr);
        }
    }
    
    if (LITH_AT_END_NO_ERR(L))
        lith_clear_error_state(L);
    else
        lith_print_error(L, 1);
}

void lith_run_file(lith_st *L, lith_env *V, char *filename)
{
    char *contents, *end;
    lith_value *expr, *result;
    L->filename = filename;
    contents = slurp(L, filename);
    if (!contents) {
        lith_print_error(L, 1);
        return;
    }
    end = contents;
    while (!LITH_IS_ERR(L)) {
        if ((expr = lith_read_expr(L, end, &end))) {
            if ((result = lith_eval_expr(L, V, expr))) {
                lith_free_value(result);
            } else {
                break;
            }
            lith_free_value(expr);
        }
    }
    free(contents);
    if (LITH_AT_END_NO_ERR(L)) {
        lith_clear_error_state(L);
        return;
    }
    
    lith_print_error(L, 1);
    if (expr) {
        fprintf(stderr, "error occurred when evaluating the expression:\n\t");
        lith_print_value(L, expr, stderr);
        fputc('\n', stderr);
        lith_free_value(expr);
    }
}