lesson-lisp/src/object.c

#include "object.h"

#include "eval.h"

#include <assert.h>
#include <stdarg.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

const char *Type_to_str(const enum Type type)
{
    switch (type) {
    case TYPE_PROCEDURE: return "TYPE_PROCEDURE";
    case TYPE_PAIR:      return "TYPE_PAIR";
    case TYPE_BOOLEAN:   return "TYPE_BOOLEAN";
    case TYPE_CHAR:      return "TYPE_CHAR";
    case TYPE_SYMBOL:    return "TYPE_SYMBOL";
    case TYPE_STRING:    return "TYPE_STRING";
    case TYPE_NUMBER:    return "TYPE_NUMBER";
    }
    return NULL;
}

/************
 * Creation *
 ************/

static struct Object *new(const enum Type type, const bool is_frozen)
{
    struct Object *const object = malloc(sizeof(struct Object));
    assert(object);
    memset(object, 0, sizeof(struct Object));
    object->type = type;
    object->is_frozen = is_frozen;
    return object;
}

struct Object *Object_new_pair(
    struct Object *const car,
    struct Object *const cdr
) {
    struct Object *const object = new(TYPE_PAIR, false);
    object->pair.car = car;
    object->pair.cdr = cdr;
    return object;
}

struct Object *Object_new_boolean(const bool boolean)
{
    struct Object *const object = new(TYPE_BOOLEAN, true);
    object->boolean = boolean;
    return object;
}

struct Object *Object_new_char(const char chr)
{
    struct Object *const object = new(TYPE_CHAR, true);
    object->chr = chr;
    return object;
}

struct Object *Object_new_symbol(const char *const s)
{
    struct Object *const object = new(TYPE_SYMBOL, true);
    object->s = malloc(strlen(s) + 1);
    assert(object->s);
    strcpy(object->s, s);
    return object;
}

struct Object *Object_new_string(const char *const s)
{
    struct Object *const object = new(TYPE_STRING, false);
    object->s = malloc(strlen(s) + 1);
    assert(object->s);
    strcpy(object->s, s);
    return object;
}

struct Object *Object_new_number(const int64_t i64)
{
    struct Object *const object = new(TYPE_NUMBER, true);
    object->number.i64 = i64;
    return object;
}

struct Object *Object_new_lambda(
    const char *const name,
    struct Object *const arg_names,
    struct Object *const body,
    struct Object *const environment
) {
    assert(OBJECT_IS_LIST_HEAD(arg_names));
    for (
        struct Object *arg_name = arg_names;
        !OBJECT_IS_NULL(arg_name);
        arg_name = arg_name->pair.cdr
    ) {
        assert(Object_is_pair(arg_name));
        assert(Object_is_symbol(arg_name->pair.car));
    }

    struct Object *const object = new(TYPE_PROCEDURE, true);
    object->procedure.name = NULL;
    if (name && name[0]) {
        object->procedure.name = malloc(strlen(name) + 1);
        assert(object->procedure.name);
        strcpy(object->procedure.name, name);
    }
    object->procedure.func = NULL;
    object->procedure.arg_names = arg_names;
    object->procedure.body = body;
    object->procedure.environment = environment;
    return object;
}

struct Object *Object_build_list(int count, ...)
{
    assert(count > 0);
    va_list va;
    va_start(va, count);

    struct Object *last = NULL;
    struct Object *list = Object_new_pair(va_arg(va, struct Object*), NULL);
    --count;

    while (count-- > 0) {
        struct Object *const new_pair =
            Object_new_pair(va_arg(va, struct Object*), NULL);

        if (last) {
            last->pair.cdr = new_pair;
            last = new_pair;
        } else {
            last = new_pair;
            list->pair.cdr = last;
        }
    }

    va_end(va);
    return list;
}

/*******************
 * Type predicates *
 *******************/

bool Object_is_procedure(struct Object *object)
{
    return object && object->type == TYPE_PROCEDURE;
}

bool Object_is_pair(struct Object *object)
{
    return object && object->type == TYPE_PAIR;
}

bool Object_is_boolean(struct Object *object)
{
    return object && object->type == TYPE_BOOLEAN;
}

bool Object_is_char(struct Object *object)
{
    return object && object->type == TYPE_CHAR;
}

bool Object_is_symbol(struct Object *object)
{
    return object && object->type == TYPE_SYMBOL;
}

bool Object_is_string(struct Object *object)
{
    return object && object->type == TYPE_STRING;
}

bool Object_is_number(struct Object *object)
{
    return object && object->type == TYPE_NUMBER;
}

/********************
 * Other predicates *
 ********************/

bool Object_is_false(struct Object *object)
{
    return Object_is_boolean(object) && object->boolean == false;
}

bool Object_is_true(struct Object *object)
{
    return Object_is_boolean(object) && object->boolean == true;
}

/**************************************
 * Helper functions for specific type *
 **************************************/

size_t Object_list_length(struct Object *list_obj)
{
    assert(OBJECT_IS_LIST_HEAD(list_obj));

    size_t length = 0;
    while (!OBJECT_IS_NULL(list_obj)) {
        ++length;
        assert(Object_is_pair(list_obj));
        list_obj = list_obj->pair.cdr;
    }
    return length;
}

struct Object *Object_procedure_call(
    struct Object *const procedure,
    struct Object *const args
) {
    assert(Object_is_procedure(procedure));
    assert(OBJECT_IS_LIST_HEAD(args));

    // Builtin procedure
    if (procedure->procedure.func) {
        const size_t args_count = Object_list_length(args);

        if (args_count == 0) {
            assert(OBJECT_IS_NULL(args));
            return procedure->procedure.func(0, NULL);
        }

        assert(Object_is_pair(args));

        const size_t size = sizeof(struct Object*) * (args_count + 1);
        struct Object **const args_array = malloc(size);
        assert(args_array);
        memset(args_array, 0, size);

        struct Object *arg = args;
        for (size_t index = 0; index < args_count; ++index) {
            assert(Object_is_pair(arg));
            args_array[index] = arg->pair.car;
            arg = arg->pair.cdr;
        }

        struct Object *const result =
            procedure->procedure.func(args_count, args_array);

        free(args_array);
        return result;
    }
    // Lambda
    else {
        assert(OBJECT_IS_LIST_HEAD(procedure->procedure.arg_names));
        assert(Object_is_pair(procedure->procedure.environment));

        struct Object *const environment =
            Object_new_pair(NULL, procedure->procedure.environment);

        for (
            struct Object
            *arg_name_pair = procedure->procedure.arg_names,
            *arg_pair      = args
            ;
            !(OBJECT_IS_NULL(arg_name_pair)) || !(OBJECT_IS_NULL(arg_pair))
            ;
            arg_name_pair = arg_name_pair->pair.cdr,
            arg_pair      = arg_pair->pair.cdr
        ) {
            assert(!OBJECT_IS_NULL(arg_name_pair));
            assert(!OBJECT_IS_NULL(arg_pair));
            struct Object *const arg_name = arg_name_pair->pair.car;
            struct Object *const arg      = arg_pair->pair.car;
            assert(Object_is_symbol(arg_name));

            environment->pair.car = Object_new_pair(
                Object_new_pair(arg_name, arg),
                environment->pair.car
            );
        }

        return eval(procedure->procedure.body, environment);
    }
}