path: root/src/main.c

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

#include "lexer.h"
#include "value.h"
#include "env.h"

#ifdef ENABLE_MEMDEBUG
#define MEMDEBUG_OUT_OF_BOUNDS
#define MEMDEBUG_IMPLEMENTATION
#define MEMDEBUG_MAIN_VOID
#define MEMDEBUG_OUTPUT_DIR "files"
#endif

#include "common.h"
#include "builtin.h"

#define LEN(arr) (sizeof(arr)/sizeof(*(arr)))

// TODO:
// - Think about memory leakage and on non fatal errors
//   like failed list creation and faild s-exp parsing
// - Check for functions not wrapped in ERR_* macro
// - Add more error messages

#ifndef DEBUG
#define TOKEN_NEXT()                            \
    ERR_NZ(lexer_token_next(lexer, &token), r,  \
           die("Can't get next token"))
#else
#define TOKEN_NEXT() do {                           \
        ERR_NZ(lexer_token_next(lexer, &token), r,  \
               die("Can't get next token"));        \
        print_token(&token);                        \
    } while(0)
#endif

#define TOKEN_ASSERT(ttype, fail)               \
    if(token.type != ttype) {                   \
        err("Expected token '%s', not '%s'",    \
            token_type_string[ttype],           \
            token_type_string[token.type]);     \
        fail;                                   \
    }

#define TOKEN_SKIP(ttype, fail) do {            \
        TOKEN_ASSERT(ttype, fail)               \
        else {                                  \
            TOKEN_NEXT();                       \
        }                                       \
    } while(0)

#define TOKEN_MATCH(ttype, fail) do {           \
        TOKEN_NEXT();                           \
        TOKEN_ASSERT(ttype, fail);              \
    } while(0)

#define HAS_ENOUGH_ARGS(proc, type, argc, fail)                     \
    if(argc != proc->value.type.argc) {                             \
        err("Wrong number of arguemnts, expected %zu, but got %zu", \
            proc->value.type.argc, argc);                           \
        fail;                                                       \
    }

#define NOT_IMPLEMENTED() die("Not Implemented. ABORTING")

static void print_token(struct token *token)
{
    char buf[256] = {0};
    ERR_Z(token_value_string(token, LEN(buf), buf), return);
    info("%-12s %s", token_type_string[token->type], buf);
}

static void print_value(value_t value)
{
    char buf[256] = {0};
    value_string(value, LEN(buf), buf);
    info("%-12s %s", value ?
         value_type_string[value->type] : "VALUE", buf);
}

static lexer_t lexer = LEXER_EMPTY;
static env_t user_env = ENV_EMPTY;

env_t env = ENV_EMPTY;
struct token token;

value_t apply(value_t proc, size_t argc, value_t *argv);

value_t evaluate_expr(void);
value_t evaluate_sexp(void);
value_t evaluate_id(void);
value_t evaluate_lambda(void);
value_t evaluate_define(void);

value_t quote_expr(void);
value_t quote_sexp(void);

size_t toklist_expr(struct token **toklist);

static void destroy_env(char *key, value_t value)
{
    (void)key;
    value_destroy(value);
}

static void destroy_user_env(char *key, value_t value)
{
    free(key);
    value_destroy(value);
}

int main(void)
{
    user_env = env_create(ENV_EMPTY, destroy_user_env);
    env = env_create(user_env, destroy_env);

    for(size_t i = 0; i < BUILTIN_PROCEDURES; i++) {
        value_t proc_value = value_create(
            VALUE_PROC_BUILTIN,
            (void *)&builtin_proc_descriptions[i]);
        hashtable_insert(env->table,
                         (void *)builtin_proc_name_list[i],
                         (void *)proc_value, NULL, NULL);
    }
    
    char *filename = "files/test.l";
        
    FILE *fp = fopen(filename, "r");
    if(!fp) {
        die("fopen: %s", strerror(errno));
    }
    
    lexer = lexer_create(fp);

    while(lexer_token_next(lexer, &token) == 0) {
        value_t val = evaluate_expr();

        #ifdef DEBUG
        print_value(val);
        #else
        char buf[256] = {0};
        value_string(val, LEN(buf), buf);
        printf("%s:%zu:   %s\n", filename, lexer->line, buf);
        #endif    
        
        value_destroy(val);
    }

    lexer_destroy(lexer);
    fclose(fp);
  
    env_destroy(env);
    // env_destroy(user_env);
    return 0;
}

value_t apply(value_t proc, size_t argc, value_t *argv)
{
    // TODO: make a global nil and copy it
    if(proc == VALUE_EMPTY) return value_create(VALUE_NIL, NULL);
    
    switch(proc->type) {
    case VALUE_PROC:
        HAS_ENOUGH_ARGS(proc, proc, argc, return VALUE_EMPTY);
        // create new env
        // evaluate body
        // destroy new env
        // switch back to the previous env

        NOT_IMPLEMENTED();
        return VALUE_EMPTY;
    case VALUE_PROC_BUILTIN:
        HAS_ENOUGH_ARGS(proc, proc_builtin, argc, return VALUE_EMPTY);
        return proc->value.proc_builtin.proc(argv);
    default:
        err("Value is not a procedure");
        return VALUE_EMPTY;
    }
}

#define IS_NOT_FIRST(arg, fail)                                \
    if(arg != 0) {                                             \
        err("special forms can only be the first argument");   \
        fail;                                                  \
    }
#define SPECIAL_FORM(ret, argc, fn, fail) do {  \
        IS_NOT_FIRST(argc, fail);               \
        ERR_Z(ret = fn, fail);                  \
    } while(0)

value_t evaluate_expr(void)
{
    value_t ret = VALUE_EMPTY;
        
    switch(token.type) {
    case TOKEN_LP:
        ERR_Z(ret = evaluate_sexp(), goto exit);
        break;
    case TOKEN_ID:
        ERR_Z(ret = evaluate_id(), goto exit);
        break;
    case TOKEN_STR:
    case TOKEN_INT:
        ERR_Z(ret = value_from_token(&token), goto exit);
        break;
    case TOKEN_QUOTE:
        TOKEN_NEXT();
        ERR_Z(ret = quote_expr(), goto exit);
        break;
    default:
        err("Did not exptect token '%s'", token_type_string[token.type]);
        break;
    }

exit:
    return ret;
}

value_t evaluate_sexp(void)
{
    value_t ret = VALUE_EMPTY;
    value_t body[256] = {VALUE_EMPTY};
    size_t argc = 0;

    TOKEN_SKIP(TOKEN_LP, goto exit);
    
    for(argc = 0; token.type != TOKEN_RP; argc++)
    {
        if(argc >= LEN(body)) {
            err("Too many arguments");
            goto exit;
        }
        
        switch(token.type) {
        case TOKEN_LAMBDA:
            SPECIAL_FORM(ret, argc, evaluate_lambda(), goto exit);
            goto exit;
        case TOKEN_DEFINE:
            SPECIAL_FORM(ret, argc, evaluate_define(), goto exit);
            goto exit;
        case TOKEN_QUOTE_FORM:
            TOKEN_NEXT();
            SPECIAL_FORM(ret, argc, quote_expr(), goto exit);
            TOKEN_MATCH(TOKEN_RP,
                        value_destroy(ret);
                        ret = VALUE_EMPTY;
                        goto exit);
            goto exit;
        default:
            ERR_Z(body[argc] = evaluate_expr(), goto exit);
            break;
        }

        TOKEN_NEXT();
    }
    
    ret = apply(body[0], argc-1, &body[1]);

    #ifdef DEBUG
    info("------------------");
    info("Applying procedure");
    print_value(body[0]);
    info("With Arguemnts");
    if(argc > 0)
        for(size_t i = 0; i < argc-1; i++) print_value(body[i+1]);
    info("Returns");
    print_value(ret);
    info("-----------------");
    #endif

exit:
    for(size_t i = 0; i < argc; i++)
        value_destroy(body[i]);
    return ret;
}

static value_t evaluate_id_env(env_t env)
{
    if(env == ENV_EMPTY) return VALUE_EMPTY;
    
    value_t ret = VALUE_EMPTY;
    ERR_NZ(hashtable_query(env->table, (void *)token.value.id, (void **)&ret), _r, return evaluate_id_env(env->parent));
    
    return value_copy(ret);
}

value_t evaluate_id(void)
{
    return evaluate_id_env(env);
}

value_t evaluate_lambda(void)
{
    value_t ret = VALUE_EMPTY;
    
    value_t args[32] = {VALUE_EMPTY};
    size_t argc = 0;
    value_t *arg_keys = NULL;
    
    struct token *body = NULL;
    size_t body_len = 0;
    
    TOKEN_SKIP(TOKEN_LAMBDA, goto fail);
    TOKEN_SKIP(TOKEN_LP, goto fail);

    while(token.type != TOKEN_RP)
    {
        if(argc >= LEN(args)) {
            err("Too many arguments");
            goto fail;
        }
        
        if(token.type != TOKEN_ID) {
            err("Token '%s' not expected in lambda args", token_type_string[token.type]);
            goto fail;
        }

        ERR_Z(args[argc++] = value_from_token(&token), goto fail);

        TOKEN_NEXT();
    }
    
    ERR_Z(body_len = toklist_expr(&body), goto fail);

    TOKEN_MATCH(TOKEN_RP, goto fail);
    
    arg_keys = calloc(argc, sizeof(*arg_keys));
    memcpy(arg_keys, args, argc * sizeof(*arg_keys));

    struct proc proc = {env_copy(env), arg_keys, argc, body, body_len};
    ERR_Z(ret = value_create(VALUE_PROC, &proc), goto fail);
    
    return ret;
    
fail:
    err("Procedure creation failed");
    for(size_t i = 0; i < argc; i++) value_destroy(args[i]);
    if(body) {
        for(size_t i = 0; i < body_len; i++) token_dealloc(&body[i]);
        free(body);
    }
    if(arg_keys) free(arg_keys);
    return VALUE_EMPTY;
}

#define STR_ALLOC_COPY(dest, str) do {    \
        size_t len = strlen(str) + 1;     \
        dest = malloc(len);               \
        memcpy((dest), (str), len);       \
    } while(0)

value_t evaluate_define(void)
{
    // TODO: don't alloc when the key is the same
    char *key = NULL;    

    // only in the outside environement
    if(env->parent != user_env) {
        err("define can only be called in the outermost environement");
        goto fail;
    }
    
    TOKEN_SKIP(TOKEN_DEFINE, goto fail);

    switch(token.type)
    {
    case TOKEN_ID:
        STR_ALLOC_COPY(key, token.value.id);
        break;
    default:
        err("Did not exptect token '%s'", token_type_string[token.type]);
        goto fail;
    }

    TOKEN_NEXT();
    
    value_t val = VALUE_EMPTY;
    ERR_Z(val = evaluate_expr(), goto fail);
    
    TOKEN_MATCH(TOKEN_RP,
                value_destroy(val);
                goto fail);

    value_t prevval = VALUE_EMPTY;
    char *prevkey = NULL;
    
    ERR_NZ(
        hashtable_insert(user_env->table, (void *)key, (void *)val,
                         (void**)&prevkey, (void **)&prevval),
        r, {
            err("Couldn't insert symbol into the hashtable due to %s", strerror(r));
            value_destroy(val); // the copy
            goto fail;
        });

    if(prevkey) free(prevkey);
    value_destroy(prevval);
    return VALUE_EMPTY;
    
fail:
    if(key) free(key);
    return VALUE_EMPTY;
}

value_t quote_expr(void)
{
    value_t ret = VALUE_EMPTY;

    switch(token.type) {
    case TOKEN_ID:
    case TOKEN_STR:
    case TOKEN_INT:
        ERR_Z(ret = value_from_token(&token), goto exit);
        break;
    case TOKEN_QUOTE:
    case TOKEN_LAMBDA:
    case TOKEN_DEFINE:
    case TOKEN_QUOTE_FORM: ;
        char name[64] = {0};
        ERR_Z(token_value_string(&token, LEN(name), name), goto exit);
        struct token temp = {0}; temp.type = TOKEN_ID; temp.value.id = name;
        ERR_Z(ret = value_from_token(&temp), goto exit);
        break;
    case TOKEN_LP:
        ERR_Z(ret = quote_sexp(), goto exit);
        break;
    case TOKEN_UNQUOTE:
        TOKEN_SKIP(TOKEN_UNQUOTE, goto exit);
        ERR_Z(ret = evaluate_expr(), goto exit);
        break;
    default:
        err("Did not exptect token '%s'", token_type_string[token.type]);
        break;
    }
exit:
    return ret;
}

value_t quote_sexp(void)
{
    value_t ret   = VALUE_EMPTY;
    value_t left  = VALUE_EMPTY;
    value_t right = VALUE_EMPTY;
    value_t nil   = VALUE_EMPTY;

    // TODO: make global nil and copy it
    ERR_Z(nil = value_create(VALUE_NIL, NULL), goto exit);
    
    TOKEN_SKIP(TOKEN_LP, goto exit);

    // Parse NIL
    if(token.type == TOKEN_RP) {
        ret = value_copy(nil);
        goto exit;
    }
        
    ERR_Z(left = quote_expr(), goto exit);

    TOKEN_NEXT();
    if(token.type == TOKEN_DOT)
    {
        // Parse cons
        TOKEN_NEXT();
        ERR_Z(right = quote_expr(), return VALUE_EMPTY);
        TOKEN_MATCH(TOKEN_RP, return VALUE_EMPTY);
        
        struct cons cons = {value_copy(left), value_copy(right)};
        ret = value_create(VALUE_CONS, &cons);
        goto exit;
    }
    
    // Parse list
    right = value_copy(nil);
    value_t *rightmost = &right; // the final nil
    while(token.type != TOKEN_RP)
    {
        value_t new = VALUE_EMPTY;
        ERR_Z(new = quote_expr(),
              goto exit);
        
        value_t new_cons = VALUE_EMPTY;
        struct cons cons = {new, *rightmost};
        ERR_Z(new_cons = value_create(VALUE_CONS, &cons),
              value_destroy(new);
              goto exit);

        *rightmost = new_cons;
        rightmost = &new_cons->value.cons.right;
        
        TOKEN_NEXT();
    }

    struct cons cons = {value_copy(left), value_copy(right)};
    ret = value_create(VALUE_CONS, &cons);
exit:
    value_destroy(left);
    value_destroy(right);
    value_destroy(nil);
    return ret;
}

size_t toklist_expr(struct token **toklist)
{
    struct token tokens[256];
    size_t tokens_len = 0;
    
    size_t depth = 0;
    do {
        TOKEN_NEXT();
        
        if(tokens_len >= LEN(tokens)) {
            err("Too many tokens in expr");
            goto fail;
        }
            
        if(token.type == TOKEN_LP) depth++;
        else if(token.type == TOKEN_RP) depth--;

        token_clone(&tokens[tokens_len++], &token);
        
    } while(depth > 0);

    *toklist = calloc(tokens_len, sizeof(*tokens));
    memcpy(*toklist, tokens, tokens_len * sizeof(*tokens));

    return tokens_len;
    
fail:
    for(size_t i = 0; i < tokens_len; i++) token_dealloc(&tokens[i]);
    return 0;
}