lesson-lisp/src/builtins.c

#include "builtins.h"

#include "lexer.h"
#include "object.h"
#include "parser.h"
#include "tokens.h"

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

// Assertions
static struct Object *func_assert_equal(size_t args_count, struct Object **args_array);
static struct Object *func_assert_false(size_t args_count, struct Object **args_array);
static struct Object *func_assert_true(size_t args_count, struct Object **args_array);
// Arcana Lisp internals
static struct Object *func_arcana_SLASH_builtin(size_t args_count, struct Object **args_array);
static struct Object *func_arcana_SLASH_parse(size_t args_count, struct Object **args_array);
static struct Object *func_arcana_SLASH_tokenize(size_t args_count, struct Object **args_array);
static struct Object *func_arcana_SLASH_typeof(size_t args_count, struct Object **args_array);
// Freezing
static struct Object *func_freeze(size_t args_count, struct Object **args_array);
static struct Object *func_frozen_QN(size_t args_count, struct Object **args_array);
// Basic data structures
static struct Object *func_car(size_t args_count, struct Object **args_array);
static struct Object *func_cdr(size_t args_count, struct Object **args_array);
static struct Object *func_cons(size_t args_count, struct Object **args_array);
static struct Object *func_list(size_t args_count, struct Object **args_array);
// Equivalence predicates
static struct Object *func_equal_QN(size_t args_count, struct Object **args_array);
// Type equivalence predicates
static struct Object *func_boolean_EQ_QN(size_t args_count, struct Object **args_array);
static struct Object *func_symbol_EQ_QN(size_t args_count, struct Object **args_array);
// Type conversion
static struct Object *func_number_TO_string(size_t args_count, struct Object **args_array);
static struct Object *func_string_TO_symbol(size_t args_count, struct Object **args_array);
static struct Object *func_symbol_TO_string(size_t args_count, struct Object **args_array);
// Arithmetic operators
static struct Object *func_EQ(size_t args_count, struct Object **args_array);
static struct Object *func_PLUS(size_t args_count, struct Object **args_array);
static struct Object *func_MINUS(size_t args_count, struct Object **args_array);
// IO
static struct Object *func_display(size_t args_count, struct Object **args_array);
static struct Object *func_newline(size_t args_count, struct Object **args_array);

#define BUILTIN(name_str, func_name) { \
    .type = TYPE_PROCEDURE,            \
    .is_frozen = true,                 \
    .procedure = {                     \
        .name = name_str,              \
        .func = func_##func_name,      \
    },                                 \
}

static struct Object builtins[] = {
    // Assertions
    BUILTIN("assert-equal", assert_equal),
    BUILTIN("assert-false", assert_false),
    BUILTIN("assert-true",  assert_true),
    // Arcana Lisp internals
    BUILTIN("arcana/builtin",  arcana_SLASH_builtin),
    BUILTIN("arcana/parse",    arcana_SLASH_parse),
    BUILTIN("arcana/tokenize", arcana_SLASH_tokenize),
    BUILTIN("arcana/typeof",   arcana_SLASH_typeof),
    // Freezing
    BUILTIN("freeze",  freeze),
    BUILTIN("frozen?", frozen_QN),
    // Basic data structures
    BUILTIN("car",  car),
    BUILTIN("cdr",  cdr),
    BUILTIN("cons", cons),
    BUILTIN("list", list),
    // Equivalence predicates
    BUILTIN("equal?", equal_QN),
    // Type equivalence predicates
    BUILTIN("boolean=?", boolean_EQ_QN),
    BUILTIN("symbol=?",  symbol_EQ_QN),
    // Type conversion
    BUILTIN("number->string", number_TO_string),
    BUILTIN("string->symbol", string_TO_symbol),
    BUILTIN("symbol->string", symbol_TO_string),
    // Arithmetic operators
    BUILTIN("=", EQ),
    BUILTIN("+", PLUS),
    BUILTIN("-", MINUS),
    // IO
    BUILTIN("display", display),
    BUILTIN("newline", newline),
    // NULL
    { .type = TYPE_PROCEDURE, .is_frozen = true, .procedure = { NULL, NULL } },
};

struct Object *builtins_get(const char *name)
{
    for (size_t index = 0; builtins[index].procedure.name; ++index) {
        if (strcmp(name, builtins[index].procedure.name) == 0) {
            return &builtins[index];
        }
    }

    return NULL;
}

/**************
 * Assertions *
 **************/

struct Object *func_assert_equal(
    size_t args_count,
    struct Object **args_array
) {
    struct Object *const result = func_equal_QN(args_count, args_array);
    if (!Object_is_true(result)) exit(EXIT_FAILURE);
    return NULL;
}

struct Object *func_assert_false(
    size_t args_count,
    struct Object **args_array
) {
    assert(args_count == 1);
    if (!Object_is_false(args_array[0])) exit(EXIT_FAILURE);
    return NULL;
}

struct Object *func_assert_true(
    size_t args_count,
    struct Object **args_array
) {
    assert(args_count == 1);
    if (!Object_is_true(args_array[0])) exit(EXIT_FAILURE);
    return NULL;
}

/*************************
 * Arcana Lisp internals *
 *************************/

struct Object *func_arcana_SLASH_builtin(
    size_t args_count,
    struct Object **args_array
) {
    assert(args_count == 1);
    struct Object *const name = args_array[0];
    assert(Object_is_symbol(name));
    return builtins_get(name->s);
}

struct Object *func_arcana_SLASH_parse(
    size_t args_count,
    struct Object **args_array
) {
    assert(args_count == 1);
    assert(args_array);

    struct Object *tokens_obj = args_array[0];
    assert(OBJECT_IS_LIST_HEAD(tokens_obj));

    const Tokens tokens = Tokens_new();
    assert(tokens);

    while (!OBJECT_IS_NULL(tokens_obj)) {
        assert(Object_is_pair(tokens_obj));

        struct Object *const token_obj = tokens_obj->pair.car;
        assert(Object_is_pair(token_obj));

        struct Object *const type_obj = token_obj->pair.car;
        assert(Object_is_symbol(type_obj));

        struct Object *const val_obj = token_obj->pair.cdr;
        assert(Object_is_string(val_obj));

        enum TokenType token_type;
        if (strcmp(type_obj->s, "TOKEN_ROUND_OPEN") == 0) {
            token_type = TOKEN_ROUND_OPEN;
        } else if (strcmp(type_obj->s, "TOKEN_ROUND_CLOSE") == 0) {
            token_type = TOKEN_ROUND_CLOSE;
        } else if (strcmp(type_obj->s, "TOKEN_SQUARE_OPEN") == 0) {
            token_type = TOKEN_SQUARE_OPEN;
        } else if (strcmp(type_obj->s, "TOKEN_SQUARE_CLOSE") == 0) {
            token_type = TOKEN_SQUARE_CLOSE;
        } else if (strcmp(type_obj->s, "TOKEN_CURLY_OPEN") == 0) {
            token_type = TOKEN_CURLY_OPEN;
        } else if (strcmp(type_obj->s, "TOKEN_CURLY_CLOSE") == 0) {
            token_type = TOKEN_CURLY_CLOSE;
        } else if (strcmp(type_obj->s, "TOKEN_QUOTE") == 0) {
            token_type = TOKEN_QUOTE;
        } else if (strcmp(type_obj->s, "TOKEN_QUASI_QUOTE") == 0) {
            token_type = TOKEN_QUASI_QUOTE;
        } else if (strcmp(type_obj->s, "TOKEN_QUASI_UNQUOTE") == 0) {
            token_type = TOKEN_QUASI_UNQUOTE;
        } else if (strcmp(type_obj->s, "TOKEN_TAG") == 0) {
            token_type = TOKEN_TAG;
        } else if (strcmp(type_obj->s, "TOKEN_IDENT") == 0) {
            token_type = TOKEN_IDENT;
        } else if (strcmp(type_obj->s, "TOKEN_NUM") == 0) {
            token_type = TOKEN_NUM;
        } else if (strcmp(type_obj->s, "TOKEN_STRING") == 0) {
            token_type = TOKEN_STRING;
        } else {
            assert(0);
        }

        Tokens_append(tokens, token_type, val_obj->s);

        tokens_obj = tokens_obj->pair.cdr;
    }

    struct Object *const program = parse(tokens);
    Tokens_delete(tokens);
    return program;
}

struct Object *func_arcana_SLASH_tokenize(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1);
    assert(args_array);

    struct Object *const str_obj = args_array[0];
    assert(Object_is_string(str_obj));

    const char *const str = str_obj->s;
    assert(str);

    Tokens tokens = Tokens_new();
    assert(tokens);

    Lexer lexer = Lexer_new(tokens);
    assert(lexer);

    for (const char *chr = str; *chr; ++chr) {
        Lexer_lex(lexer, *chr);
    }
    Lexer_lex(lexer, '\n');

    LEXER_DELETE(lexer);
    struct Object *list = NULL;

    if (Tokens_top(tokens)) {
        struct Object *last = NULL;
        list = Object_new_pair(
            Object_new_pair(
                Object_new_symbol(TokenType_to_str(Tokens_top(tokens)->type)),
                Object_new_string(Tokens_top(tokens)->val)
            ),
            NULL
        );
        Tokens_pop(tokens);

        while (Tokens_top(tokens)) {
            struct Object *const new_pair = Object_new_pair(
                Object_new_pair(
                    Object_new_symbol(TokenType_to_str(Tokens_top(tokens)->type)),
                    Object_new_string(Tokens_top(tokens)->val)
                ),
                NULL
            );
            Tokens_pop(tokens);

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

    TOKENS_DELETE(tokens);
    return list;
}

struct Object *func_arcana_SLASH_typeof(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1);
    assert(args_array);

    struct Object *const object = args_array[0];

    if (OBJECT_IS_NULL(object)) return Object_new_symbol("null");

    switch (object->type) {
    case TYPE_PROCEDURE: return Object_new_symbol("procedure");
    case TYPE_PAIR:      return Object_new_symbol("pair");
    case TYPE_BOOLEAN:   return Object_new_symbol("boolean");
    case TYPE_CHAR:      return Object_new_symbol("char");
    case TYPE_SYMBOL:    return Object_new_symbol("symbol");
    case TYPE_STRING:    return Object_new_symbol("string");
    case TYPE_NUMBER:    return Object_new_symbol("number");
    }

    assert(0);
    return NULL;
}

/************
 * Freezing *
 ************/

struct Object *func_freeze(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1);
    if (!OBJECT_IS_NULL(args_array[0])) args_array[0]->is_frozen = true;
    return args_array[0];
}

struct Object *func_frozen_QN(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1);
    return Object_new_boolean(
        OBJECT_IS_NULL(args_array[0]) ||
        args_array[0]->is_frozen
    );
}

/*************************
 * Basic data structures *
 *************************/

struct Object *func_car(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1);

    struct Object *const arg = args_array[0];
    assert(Object_is_pair(arg));

    return arg->pair.car;
}

struct Object *func_cdr(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1);

    struct Object *const arg = args_array[0];
    assert(Object_is_pair(arg));

    return arg->pair.cdr;
}

struct Object *func_cons(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 2);
    return Object_new_pair(args_array[0], args_array[1]);
}

struct Object *func_list(
    const size_t args_count,
    struct Object **const args_array
) {
    if (args_count == 0) return NULL;
    return Object_new_pair(
        args_array[0],
        func_list(args_count - 1, &args_array[1])
    );
}

/**************************
 * Equivalence predicates *
 **************************/

struct Object *func_equal_QN(
    const size_t args_count,
    struct Object **const args_array
) {
    if (args_count <= 1) return Object_new_boolean(true);

    struct Object *const first = args_array[0];
    struct Object *const result = Object_new_boolean(true);

    for (size_t index = 1; result->boolean && index < args_count; ++index) {
        struct Object *const curr = args_array[index];

        if (OBJECT_IS_NULL(first)) {
            if (!OBJECT_IS_NULL(curr)) result->boolean = false;
        } else {
            if (curr->type != first->type) {
                result->boolean = false;
                break;
            }

            switch (first->type) {
            case TYPE_PROCEDURE:
                // Built-in
                if (first->procedure.func) {
                    result->boolean =
                        curr->procedure.func &&
                        !strcmp(first->procedure.name, curr->procedure.name);
                }
                // Lambda
                else {
                    result->boolean = curr == first;
                }
                break;
            case TYPE_PAIR:
            {
                struct Object *car_args[2] =
                    { first->pair.car, curr->pair.car };
                struct Object *cdr_args[2] =
                    { first->pair.cdr, curr->pair.cdr };
                struct Object *car_obj = func_equal_QN(2, car_args);
                struct Object *cdr_obj = func_equal_QN(2, cdr_args);
                assert(Object_is_boolean(car_obj));
                assert(Object_is_boolean(cdr_obj));
                result->boolean = car_obj->boolean && cdr_obj->boolean;
                break;
            }
            case TYPE_BOOLEAN:
                result->boolean = first->boolean == curr->boolean;
                break;
            case TYPE_CHAR:
                result->boolean = first->chr == curr->chr;
                break;
            case TYPE_SYMBOL:
            case TYPE_STRING:
                result->boolean = !strcmp(first->s, curr->s);
                break;
            case TYPE_NUMBER:
                result->boolean = first->number.i64 == curr->number.i64;
                break;
            }
        }
    }

    return result;
}

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

struct Object *func_boolean_EQ_QN(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count > 0);

    struct Object *const first = args_array[0];
    assert(Object_is_boolean(first));

    struct Object *const result = Object_new_boolean(true);

    for (size_t index = 1; result->boolean && index < args_count; ++index) {
        assert(Object_is_boolean(args_array[index]));
    }

    for (size_t index = 1; result->boolean && index < args_count; ++index) {
        struct Object *const curr = args_array[index];
        if (curr->boolean != first->boolean) result->boolean = false;
    }

    return result;
}

struct Object *func_symbol_EQ_QN(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count > 0);

    struct Object *const first = args_array[0];
    assert(Object_is_symbol(first));

    struct Object *const result = Object_new_boolean(true);

    for (size_t index = 1; result->boolean && index < args_count; ++index) {
        assert(Object_is_symbol(args_array[index]));
    }

    for (size_t index = 1; result->boolean && index < args_count; ++index) {
        struct Object *const curr = args_array[index];
        if (strcmp(curr->s, first->s)) result->boolean = false;
    }

    return result;
}

/*******************
 * Type conversion *
 *******************/

struct Object *func_number_TO_string(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1 || args_count == 2);

    struct Object *const z = args_array[0];
    assert(Object_is_number(z));

    int64_t radix = 10;
    if (args_count == 2) {
        struct Object *radix_obj = args_array[1];
        assert(Object_is_number(radix_obj));
        radix = radix_obj->number.i64;
    }

    char buffer[70];

    switch (radix) {
    case 2:
        assert(0); // TODO
        break;
    case 8:
        snprintf(buffer, 70, "%lo", z->number.i64);
        break;
    case 10:
        snprintf(buffer, 70, "%ld", z->number.i64);
        break;
    case 16:
        snprintf(buffer, 70, "%lx", z->number.i64);
        break;
    default:
        assert(0);
    }

    return Object_new_string(buffer);
}

struct Object *func_string_TO_symbol(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1);
    struct Object *const string = args_array[0];
    assert(Object_is_string(string));
    return Object_new_symbol(string->s);
}

struct Object *func_symbol_TO_string(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1);
    struct Object *const symbol = args_array[0];
    assert(Object_is_symbol(symbol));
    return Object_new_string(symbol->s);
}

/************************
 * Arithmetic operators *
 ************************/

struct Object *func_EQ(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count >= 1);

    struct Object *const first = args_array[0];
    assert(Object_is_number(first));

    struct Object *const result = Object_new_boolean(true);

    for (size_t index = 1; index < args_count; ++index) {
        struct Object *const cur = args_array[index];
        assert(Object_is_number(cur));

        if (cur->number.i64 != first->number.i64) {
            result->boolean = false;
            break;
        }
    }

    return result;
}

struct Object *func_PLUS(
    const size_t args_count,
    struct Object **const args_array
) {
    struct Object *const object = Object_new_number(0);
    if (args_count == 0) return object;

    struct Object *const arg = args_array[0];
    assert(Object_is_number(arg));

    object->number.i64 = arg->number.i64;
    if (args_count == 1) return object;

    struct Object *const b_sum = func_PLUS(args_count - 1, &args_array[1]);
    object->number.i64 += b_sum->number.i64;
    return object;
}

struct Object *func_MINUS(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count >= 1);
    struct Object *const arg = args_array[0];
    assert(Object_is_number(arg));

    struct Object *const object = Object_new_number(arg->number.i64);

    if (args_count >= 2) {
        struct Object *const sum = func_PLUS(args_count - 1, &args_array[1]);
        assert(Object_is_number(sum));
        object->number.i64 -= sum->number.i64;
    }

    return object;
}

/******
 * IO *
 ******/

static void display_pair(struct Object *pair);

struct Object *func_display(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 1);

    struct Object *const object = args_array[0];

    if (!object) {
        printf("()");
        return NULL;
    }

    switch (object->type) {
    case TYPE_PROCEDURE:
        if (object->procedure.name) {
            printf("#<procedure:%s>", object->procedure.name);
        } else {
            printf("#<procedure>");
        }
        break;
    case TYPE_PAIR:
        printf("(");
        display_pair(object);
        printf(")");
        break;
    case TYPE_BOOLEAN:
        printf("%s", object->boolean ? "#true" : "#false");
        break;
    case TYPE_CHAR:
        printf("#\\TODO"); // TODO
        break;
    case TYPE_SYMBOL:
        printf("%s", object->s);
        break;
    case TYPE_NUMBER:
        printf("%li", object->number.i64);
        break;
    case TYPE_STRING:
        putchar('"');
        for (char *str = object->s; *str; ++str) {
            const char chr = *str;
            if (chr == '\\') {
                printf("\\\\");
            } else if (chr == '\"') {
                printf("\\\"");
            } else {
                putchar(chr);
            }
        }
        putchar('"');
        break;
    }

    return NULL;
}

struct Object *func_newline(
    const size_t args_count,
    struct Object **const args_array
) {
    assert(args_count == 0);
    (void)args_array;

    printf("\n");
    return NULL;
}

void display_pair(struct Object *const pair)
{
    assert(Object_is_pair(pair));

    struct Object *pair1[2] = { pair->pair.car, NULL };
    func_display(1, pair1);

    if (!pair->pair.cdr) return;

    printf(" ");

    if (Object_is_pair(pair->pair.cdr)) {
        display_pair(pair->pair.cdr);
        return;
    }

    printf(". ");
    struct Object *pair2[2] = { pair->pair.cdr, NULL };
    func_display(1, pair2);
}