aboutsummaryrefslogtreecommitdiff
path: root/src/main.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/main.c')
-rw-r--r--src/main.c324
1 files changed, 266 insertions, 58 deletions
diff --git a/src/main.c b/src/main.c
index 0ddb7f9..d0227e8 100644
--- a/src/main.c
+++ b/src/main.c
@@ -2,6 +2,7 @@
#include <stdlib.h>
#include <string.h>
#include <getopt.h>
+#include <stdbool.h>
#include "lexer.h"
#include "value.h"
@@ -62,11 +63,22 @@ static void print_token(struct token *token)
static void print_value(value_t value)
{
char buf[256] = {0};
- value_string(value, LEN(buf), buf);
+ value_string(value, sizeof(buf), buf);
info("%-12s %s", value ?
value_type_string[value->type] : "VALUE", buf);
}
+static void print_toklist(struct toklist *toklist)
+{
+ info("TOKLIST_START");
+ list_for_each(pos, &toklist->list) {
+ struct toklist *entry = list_entry(pos, struct toklist, list);
+ for(size_t i = 0; i < entry->tokens_len; i++)
+ print_token(&entry->tokens[i]);
+ }
+ info("TOKLIST_END");
+}
+
struct tctx {
enum tctx_type {
TCTX_LEXER,
@@ -82,8 +94,7 @@ struct tctx {
} lex_ctx;
struct tok_ctx {
- struct token *list;
- size_t len;
+ struct toklist *head;
size_t idx;
} tok_ctx;
} value;
@@ -96,11 +107,10 @@ static void tctx_init_lexer(struct tctx *tctx, lexer_t lexer)
tctx->token = &tctx->value.lex_ctx.token;
}
-static void tctx_init_toklist(struct tctx *tctx, struct token *toklist, size_t len)
+static void tctx_init_toklist(struct tctx *tctx, struct toklist *list)
{
tctx->type = TCTX_TOKLIST;
- tctx->value.tok_ctx.list = toklist;
- tctx->value.tok_ctx.len = len;
+ tctx->value.tok_ctx.head = list;
tctx->value.tok_ctx.idx = 0;
tctx->token = NULL;
}
@@ -115,8 +125,12 @@ static struct token *next_token(struct tctx *tctx)
break;
case TCTX_TOKLIST: ;
struct tok_ctx *t = &tctx->value.tok_ctx;
- if(t->idx == t->len) goto fail;
- tctx->token = &t->list[t->idx++];
+ while(t->idx >= t->head->tokens_len) {
+ ERR_NZ(list_is_tail(&t->head->list), _r, goto fail);
+ t->head = list_next_entry(t->head, struct toklist, list);
+ t->idx = 0;
+ }
+ tctx->token = &t->head->tokens[t->idx++];
break;
}
@@ -126,8 +140,9 @@ fail:
return NULL;
}
+static char *str_alloc_copy(char *src);
-value_t apply(value_t proc, size_t argc, value_t *argv);
+value_t apply(env_t env, value_t proc, size_t argc, value_t *argv);
value_t evaluate_expr(env_t env, struct tctx *tctx);
value_t evaluate_sexp(env_t env, struct tctx *tctx);
@@ -136,11 +151,15 @@ value_t evaluate_id (env_t env, struct tctx *tctx);
value_t evaluate_lambda(env_t env, struct tctx *tctx);
value_t evaluate_define(env_t env, struct tctx *tctx);
value_t evaluate_if (env_t env, struct tctx *tctx);
+value_t evaluate_defmacro(env_t env, struct tctx *tctx);
+
+value_t quote_expr(env_t env, struct tctx *tctx, bool is_quasi);
+value_t quote_sexp(env_t env, struct tctx *tctx, bool is_quasi);
-value_t quote_expr(env_t env, struct tctx *tctx);
-value_t quote_sexp(env_t env, struct tctx *tctx);
+static int toklist_expr(struct tctx *tctx, struct toklist **toklist);
-size_t toklist_expr(struct tctx *tctx, struct token **toklist);
+static struct toklist *value_to_toklist(value_t value);
+static struct toklist *cons_to_toklist(value_t value);
static env_t global_env = ENV_EMPTY;
static value_t global_nil = VALUE_EMPTY;
@@ -249,6 +268,14 @@ int main(int argc, char **argv)
return 0;
}
+static char *str_alloc_copy(char *src)
+{
+ if(!src) return src;
+
+ size_t len = strlen(src) + 1;
+ return memcpy(malloc(len), src, len);
+}
+
#define HAS_ENOUGH_ARGS(proc, type, argc, fail) \
if(argc != proc->value.type.argc) { \
err("Wrong number of arguemnts, expected %zu, but got %zu", \
@@ -263,7 +290,7 @@ static value_t apply_lambda(struct proc *proc, value_t *args)
struct tctx tctx = {0};
ERR_Z(env = env_create(env_copy(proc->parent_env), destroy_env), goto exit);
- tctx_init_toklist(&tctx, proc->body, proc->body_len);
+ tctx_init_toklist(&tctx, proc->body);
for(size_t i = 0; i < proc->argc; i++) {
ERR_NZ(hashtable_insert(env->table,
@@ -279,7 +306,30 @@ exit:
return ret;
}
-value_t apply(value_t proc, size_t argc, value_t *argv)
+static value_t apply_macro(env_t env, struct proc *proc, value_t *args)
+{
+ value_t ret = VALUE_EMPTY;
+ value_t macro_ret = VALUE_EMPTY;
+
+ struct toklist *toklist = NULL;
+
+ ERR_Z(macro_ret = apply_lambda(proc, args), goto exit);
+ ERR_Z(toklist = value_to_toklist(macro_ret), goto exit);
+
+ struct tctx tctx = {0};
+ tctx_init_toklist(&tctx, toklist);
+
+ TOKEN_NEXT(&tctx);
+ ret = evaluate_expr(env, &tctx);
+
+exit:
+ if(toklist) toklist_destroy(toklist);
+ value_destroy(macro_ret);
+
+ return ret;
+}
+
+value_t apply(env_t env, value_t proc, size_t argc, value_t *argv)
{
if(proc == VALUE_EMPTY) return value_copy(global_nil);
@@ -287,11 +337,14 @@ value_t apply(value_t proc, size_t argc, value_t *argv)
case VALUE_PROC:
HAS_ENOUGH_ARGS(proc, proc, argc, return VALUE_EMPTY);
return apply_lambda(&proc->value.proc, argv);
+ case VALUE_MACRO:
+ HAS_ENOUGH_ARGS(proc, proc, argc, return VALUE_EMPTY);
+ return apply_macro(env, &proc->value.proc, argv);
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");
+ err("'%s' is not a procedure", value_type_string[proc->type]);
return VALUE_EMPTY;
}
}
@@ -313,7 +366,11 @@ value_t evaluate_expr(env_t env, struct tctx *tctx)
break;
case TOKEN_QUOTE:
TOKEN_NEXT(tctx);
- ERR_Z(ret = quote_expr(env, tctx), goto exit);
+ ERR_Z(ret = quote_expr(env, tctx, false), goto exit);
+ break;
+ case TOKEN_QUASI:
+ TOKEN_NEXT(tctx);
+ ERR_Z(ret = quote_expr(env, tctx, true), goto exit);
break;
default:
err("Did not exptect token '%s'", token_type_string[TOKEN(tctx)->type]);
@@ -349,6 +406,14 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx)
goto exit;
}
+ if(body[0])
+ if(body[0]->type == VALUE_MACRO) {
+ ERR_Z(body[argc] = quote_expr(env, tctx, false), goto exit);
+
+ TOKEN_NEXT(tctx);
+ continue;
+ }
+
switch(TOKEN(tctx)->type) {
case TOKEN_LAMBDA:
SPECIAL_FORM(ret, argc, evaluate_lambda(env, tctx), goto exit);
@@ -358,7 +423,7 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx)
goto exit;
case TOKEN_QUOTE_FORM:
TOKEN_NEXT(tctx);
- SPECIAL_FORM(ret, argc, quote_expr(env, tctx), goto exit);
+ SPECIAL_FORM(ret, argc, quote_expr(env, tctx, false), goto exit);
TOKEN_MATCH(tctx, TOKEN_RP,
value_destroy(ret);
ret = VALUE_EMPTY;
@@ -367,6 +432,9 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx)
case TOKEN_IF:
SPECIAL_FORM(ret, argc, evaluate_if(env, tctx), goto exit);
goto exit;
+ case TOKEN_DEFMACRO:
+ SPECIAL_FORM(ret, argc, evaluate_defmacro(env, tctx), goto exit);
+ goto exit;
default:
ERR_Z(body[argc] = evaluate_expr(env, tctx), goto exit);
break;
@@ -375,7 +443,7 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx)
TOKEN_NEXT(tctx);
}
- ret = apply(body[0], argc-1, &body[1]);
+ ret = apply(env, body[0], argc-1, &body[1]);
exit:
for(size_t i = 0; i < argc; i++)
@@ -410,8 +478,7 @@ value_t evaluate_lambda(env_t env, struct tctx *tctx)
size_t argc = 0;
value_t *arg_keys = NULL;
- struct token *body = NULL;
- size_t body_len = 0;
+ struct toklist *body = NULL;
TOKEN_SKIP(tctx, TOKEN_LAMBDA, goto fail);
TOKEN_SKIP(tctx, TOKEN_LP, goto fail);
@@ -433,14 +500,14 @@ value_t evaluate_lambda(env_t env, struct tctx *tctx)
TOKEN_NEXT(tctx);
}
- ERR_Z(body_len = toklist_expr(tctx, &body), goto fail);
+ ERR_NZ(toklist_expr(tctx, &body), _r, goto fail);
TOKEN_MATCH(tctx, 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};
+ struct proc proc = {env_copy(env), arg_keys, argc, body};
ERR_Z(ret = value_create(VALUE_PROC, &proc),
env_destroy(env); // remove the copy
goto fail);
@@ -450,20 +517,11 @@ value_t evaluate_lambda(env_t env, struct tctx *tctx)
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(body) toklist_destroy(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(env_t env, struct tctx *tctx)
{
// TODO: don't alloc when the key is the same
@@ -480,7 +538,7 @@ value_t evaluate_define(env_t env, struct tctx *tctx)
switch(TOKEN(tctx)->type)
{
case TOKEN_ID:
- STR_ALLOC_COPY(key, TOKEN(tctx)->value.id);
+ key = str_alloc_copy(TOKEN(tctx)->value.id);
break;
default:
err("Did not exptect token '%s'", token_type_string[TOKEN(tctx)->type]);
@@ -556,7 +614,53 @@ exit:
return ret;
}
-value_t quote_expr(env_t env, struct tctx *tctx)
+value_t evaluate_defmacro(env_t env, struct tctx *tctx)
+{
+ char *key = NULL;
+ value_t lambda = VALUE_EMPTY;
+
+ TOKEN_SKIP(tctx, TOKEN_DEFMACRO, goto fail);
+
+ switch(TOKEN(tctx)->type)
+ {
+ case TOKEN_ID:
+ key = str_alloc_copy(TOKEN(tctx)->value.id);
+ break;
+ default:
+ err("Did not exptect token '%s'", token_type_string[TOKEN(tctx)->type]);
+ goto fail;
+ }
+
+ // unsafe and bad
+ tctx->token->type = TOKEN_LAMBDA;
+
+ ERR_Z(lambda = evaluate_lambda(env, tctx), goto fail);
+ lambda->type = VALUE_MACRO;
+
+ // TOKEN_MATCH(tctx, TOKEN_RP, goto fail);
+
+ value_t prevval = VALUE_EMPTY;
+ char *prevkey = NULL;
+
+ ERR_NZ(
+ hashtable_insert(global_env->table, (void *)key, (void *)lambda,
+ (void**)&prevkey, (void **)&prevval),
+ r, {
+ err("Couldn't insert symbol into the hashtable due to %s", strerror(r));
+ goto fail;
+ });
+
+ if(prevkey) free(prevkey);
+ value_destroy(prevval);
+ return value_copy(global_nil);
+
+fail:
+ value_destroy(lambda);
+ if(key)free(key);
+ return VALUE_EMPTY;
+}
+
+value_t quote_expr(env_t env, struct tctx *tctx, bool is_quasi)
{
value_t ret = VALUE_EMPTY;
@@ -566,23 +670,28 @@ value_t quote_expr(env_t env, struct tctx *tctx)
case TOKEN_INT:
ERR_Z(ret = value_from_token(TOKEN(tctx)), goto exit);
break;
+ case TOKEN_UNQUOTE:
+ if(is_quasi) {
+ TOKEN_SKIP(tctx, TOKEN_UNQUOTE, goto exit);
+ ERR_Z(ret = evaluate_expr(env, tctx), goto exit);
+ break;
+ }
case TOKEN_QUOTE:
+ case TOKEN_QUASI:
case TOKEN_LAMBDA:
case TOKEN_DEFINE:
case TOKEN_QUOTE_FORM:
- case TOKEN_IF: ;
+ case TOKEN_IF:
+ case TOKEN_DEFMACRO: ;
char name[64] = {0};
ERR_Z(token_value_string(TOKEN(tctx), 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(env, tctx), goto exit);
- break;
- case TOKEN_UNQUOTE:
- TOKEN_SKIP(tctx, TOKEN_UNQUOTE, goto exit);
- ERR_Z(ret = evaluate_expr(env, tctx), goto exit);
+ ERR_Z(ret = quote_sexp(env, tctx, is_quasi), goto exit);
break;
+
default:
err("Did not exptect token '%s'", token_type_string[TOKEN(tctx)->type]);
break;
@@ -591,7 +700,7 @@ exit:
return ret;
}
-value_t quote_sexp(env_t env, struct tctx *tctx)
+value_t quote_sexp(env_t env, struct tctx *tctx, bool is_quasi)
{
value_t ret = VALUE_EMPTY;
value_t left = VALUE_EMPTY;
@@ -604,14 +713,14 @@ value_t quote_sexp(env_t env, struct tctx *tctx)
goto exit;
}
- ERR_Z(left = quote_expr(env, tctx), goto exit);
+ ERR_Z(left = quote_expr(env, tctx, is_quasi), goto exit);
TOKEN_NEXT(tctx);
if(TOKEN(tctx)->type == TOKEN_DOT)
{
// Parse cons
TOKEN_NEXT(tctx);
- ERR_Z(right = quote_expr(env, tctx), return VALUE_EMPTY);
+ ERR_Z(right = quote_expr(env, tctx, is_quasi), return VALUE_EMPTY);
TOKEN_MATCH(tctx, TOKEN_RP, return VALUE_EMPTY);
struct cons cons = {value_copy(left), value_copy(right)};
@@ -629,7 +738,7 @@ value_t quote_sexp(env_t env, struct tctx *tctx)
if(TOKEN(tctx)->type == TOKEN_DOT) {
TOKEN_NEXT(tctx);
- ERR_Z(new = quote_expr(env, tctx), goto exit);
+ ERR_Z(new = quote_expr(env, tctx, is_quasi), goto exit);
TOKEN_MATCH(tctx, TOKEN_RP,
value_destroy(new);
@@ -640,7 +749,7 @@ value_t quote_sexp(env_t env, struct tctx *tctx)
break;
}
- ERR_Z(new = quote_expr(env, tctx),
+ ERR_Z(new = quote_expr(env, tctx, is_quasi),
goto exit);
value_t new_cons = VALUE_EMPTY;
@@ -663,37 +772,136 @@ exit:
return ret;
}
-#define IS_OP(token) (token->type == TOKEN_QUOTE)
-size_t toklist_expr(struct tctx *tctx, struct token **toklist)
+static struct toklist *toklist_create(struct token *tokens, size_t tokens_len)
+{
+ struct toklist *toklist;
+ toklist = malloc(sizeof(*toklist));
+ LIST_EMPTY(&toklist->list);
+
+ toklist->tokens = calloc(tokens_len, sizeof(*tokens));
+ memcpy(toklist->tokens, tokens, tokens_len * sizeof(*tokens));
+ toklist->tokens_len = tokens_len;
+
+ return toklist;
+}
+
+#define IS_OP(token) (token->type == TOKEN_QUOTE || \
+ token->type == TOKEN_QUASI || \
+ token->type == TOKEN_UNQUOTE)
+
+static int toklist_expr(struct tctx *tctx, struct toklist **toklist)
{
- struct token tokens[256];
+ struct token tokens[64] = {0};
size_t tokens_len = 0;
+ struct list_head *tail = LIST_END;
+
size_t depth = 0;
+
do {
TOKEN_NEXT(tctx);
if(tokens_len >= LEN(tokens)) {
- err("Too many tokens in expr");
- goto fail;
+ if(toklist) {
+ tail = list_add(tail, &toklist_create(tokens, tokens_len)->list);
+ }
+ tokens_len = 0;
}
if(TOKEN(tctx)->type == TOKEN_LP) depth++;
else if(TOKEN(tctx)->type == TOKEN_RP) depth--;
+
+ if(toklist)
+ token_clone(&tokens[tokens_len++], TOKEN(tctx));
- token_clone(&tokens[tokens_len++], TOKEN(tctx));
+ } while(depth != 0 || IS_OP(TOKEN(tctx)));
- } while(depth > 0 || IS_OP(TOKEN(tctx)));
+ if(toklist) {
+ tail = list_add(tail, &toklist_create(tokens, tokens_len)->list);
+ *toklist = list_entry(list_get_head(tail), struct toklist, list);
+ }
- if(!toklist) goto fail;
+ return 0;
+
+// fail:
+ // for(size_t i = 0; i < tokens_len; i++) token_dealloc(&tokens[i]);
+ // return 1;
+}
+
+#define SET_TOKEN_TYPE(t, ttype) (t)->type = (ttype)
+#define SET_TOKEN_VALUE(t, member, tvalue) (t)->value.member = (tvalue)
+
+static struct toklist *value_to_toklist(value_t value)
+{
+ struct token token = {0};
+
+ switch(value->type) {
+ case VALUE_ATOM:
+ SET_TOKEN_TYPE(&token, TOKEN_ID);
+ SET_TOKEN_VALUE(&token, id,
+ str_alloc_copy(value->value.atom));
+ break;
+ case VALUE_STR:
+ SET_TOKEN_TYPE(&token, TOKEN_STR);
+ SET_TOKEN_VALUE(&token, str,
+ str_alloc_copy(value->value.str));
+ break;
+ case VALUE_INT:
+ SET_TOKEN_TYPE(&token, TOKEN_INT);
+ SET_TOKEN_VALUE(&token, num, value->value.num);
+ break;
+ case VALUE_CONS:
+ return cons_to_toklist(value);
+ default:
+ err("Cant turn '%s' to a token", value_type_string[value->type]);
+ return NULL;
+ }
+
+ return toklist_create(&token, 1);
+}
+
+static struct list_head *add_token_toklist(enum token_type type, struct list_head *tail)
+{
+ struct token token = {0};
+ token.type = type;
+ return list_add(tail, &(toklist_create(&token, 1)->list));
+}
+
+static struct toklist *cons_to_toklist(value_t value)
+{
+#define ADD_TOKEN(tail, ttype) \
+ tail = add_token_toklist(ttype, tail)
+#define ADD_TOKLIST(tail, toklist) \
+ tail = list_get_tail(list_append(tail, &toklist->list))
+
+ struct list_head *tail = LIST_END;
+
+ ADD_TOKEN(tail, TOKEN_LP);
+
+ while(1) {
+ value_t left = value->value.cons.left;
+ value = value->value.cons.right;
- *toklist = calloc(tokens_len, sizeof(*tokens));
- memcpy(*toklist, tokens, tokens_len * sizeof(*tokens));
+ struct toklist *new = NULL;
+ ERR_Z(new = value_to_toklist(left), goto fail);
+ ADD_TOKLIST(tail, new);
- return tokens_len;
+ if(value->type == VALUE_NIL) break;
+ if(value->type != VALUE_CONS) {
+ ADD_TOKEN(tail, TOKEN_DOT);
+ ERR_Z(new = value_to_toklist(value), goto fail);
+ ADD_TOKLIST(tail, new);
+ break;
+ }
+ }
+
+ ADD_TOKEN(tail, TOKEN_RP);
+
+ return list_entry(list_get_head(tail), struct toklist, list);
fail:
- for(size_t i = 0; i < tokens_len; i++) token_dealloc(&tokens[i]);
- return 0;
+ err("Failed to turn value to toklist");
+ toklist_destroy(list_entry(list_get_head(tail), struct toklist, list));
+ return NULL;
}
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 05:15:18 +0000