Mark Poliakov
91961bcec5
1. (list ...) 2. string-* functions 3. (native str) to resolve native functions at runtime 4. Memory fuckups in compiler core unit loading 5. Now can call non-identifiers in compiler
245 lines
7.4 KiB
C
245 lines
7.4 KiB
C
#include "builtin.h"
|
|
#include "compile.h"
|
|
#include "vector.h"
|
|
#include "unit.h"
|
|
#include "node.h"
|
|
#include "op.h"
|
|
|
|
#include <assert.h>
|
|
#include <string.h>
|
|
#include <stdio.h>
|
|
|
|
static void emit_rev_cons(struct function *fn,
|
|
struct context *ctx,
|
|
struct node *args) {
|
|
if (null_q(args)) {
|
|
return;
|
|
}
|
|
emit_rev_cons(fn, ctx, cdr(args));
|
|
emit(fn, ctx, car(args));
|
|
emit_insn(fn, OP(OP_CONS, 0));
|
|
}
|
|
|
|
int emit_builtin_syntax(struct function *fn,
|
|
struct context *ctx,
|
|
const char *name,
|
|
struct node *tail) {
|
|
struct node *arg0, *arg1, *arg2;
|
|
int kind;
|
|
size_t index;
|
|
|
|
// Only setq/define use this instruction
|
|
// TODO your defmacro could be here...
|
|
if (!strcmp(name, "define")) {
|
|
arg0 = car(tail);
|
|
|
|
if (ident_q(arg0)) {
|
|
arg1 = cadr(tail);
|
|
assert(null_q(cddr(tail)));
|
|
|
|
if (ctx_lookup_name(ctx, arg0->n_ident, &kind, &index) != 0) {
|
|
fprintf(stderr, "Unresolved reference to %s\n", arg0->n_ident);
|
|
abort();
|
|
}
|
|
|
|
// (define ident value)
|
|
// Emit value for n1
|
|
emit(fn, ctx, arg1);
|
|
emit_store(fn, kind, index);
|
|
} else if (cons_q(arg0)) {
|
|
struct node *name = car(arg0);
|
|
struct node *args = cdr(arg0);
|
|
struct node *body = cdr(tail);
|
|
|
|
assert(ident_q(name));
|
|
assert(ctx_lookup_name(ctx, name->n_ident, &kind, &index) == 0);
|
|
|
|
struct function *new_fn = unit_lambda(ctx->root);
|
|
struct context new_ctx;
|
|
new_fn->args = args;
|
|
new_fn->body = body;
|
|
new_fn->local_count = 0;
|
|
if (ctx->parent) {
|
|
ctx_init(&new_ctx, ctx->parent);
|
|
} else {
|
|
ctx_init(&new_ctx, ctx);
|
|
}
|
|
new_ctx.var_counter = 0;
|
|
new_ctx.owner = new_fn;
|
|
|
|
emit_function(&new_ctx, new_fn);
|
|
emit_insn(fn, OP(OP_LDF, new_fn->index));
|
|
emit_store(fn, kind, index);
|
|
}
|
|
return 0;
|
|
} else if (!strcmp(name, "setq")) {
|
|
arg0 = car(tail);
|
|
arg1 = cadr(tail);
|
|
assert(null_q(cddr(tail)));
|
|
|
|
assert(ident_q(arg0));
|
|
assert(ctx_lookup_name(ctx, arg0->n_ident, &kind, &index) == 0);
|
|
emit(fn, ctx, arg1);
|
|
emit_store(fn, kind, index);
|
|
return 0;
|
|
} else if (!strcmp(name, "lambda")) {
|
|
// (lambda list body...)
|
|
arg0 = car(tail);
|
|
arg1 = cdr(tail);
|
|
assert(cons_q(arg0));
|
|
assert(!null_q(arg1));
|
|
|
|
struct function *new_fn = unit_lambda(ctx->root);
|
|
struct context new_ctx;
|
|
new_fn->args = arg0;
|
|
new_fn->body = arg1;
|
|
new_fn->local_count = 0;
|
|
assert(!ctx->parent);
|
|
ctx_init(&new_ctx, ctx);
|
|
new_ctx.var_counter = 0;
|
|
new_ctx.owner = new_fn;
|
|
|
|
emit_function(&new_ctx, new_fn);
|
|
emit_insn(fn, OP(OP_LDF, new_fn->index));
|
|
|
|
return 0;
|
|
} else if (!strcmp(name, "begin")) {
|
|
assert(!null_q(tail));
|
|
|
|
for (arg0 = tail; arg0; arg0 = cdr(arg0)) {
|
|
emit(fn, ctx, car(arg0));
|
|
}
|
|
return 0;
|
|
} else if (!strcmp(name, "if")) {
|
|
arg0 = car(tail);
|
|
arg1 = cadr(tail);
|
|
arg2 = caddr(tail);
|
|
assert(null_q(cdr(cddr(tail))));
|
|
|
|
emit(fn, ctx, arg0);
|
|
// Will hop back and modify an already emitted jump with a proper
|
|
// offset
|
|
size_t cond_jmp_loc = fn->bytecode.size;
|
|
emit_insn(fn, OP(OP_BF, 0));
|
|
|
|
// Emit "yes" branch
|
|
emit(fn, ctx, arg1);
|
|
size_t yes_jmp_loc = fn->bytecode.size;
|
|
emit_insn(fn, OP(OP_JMP, 0));
|
|
|
|
// Emit "no" branch
|
|
size_t no_loc = fn->bytecode.size;
|
|
emit(fn, ctx, arg2);
|
|
|
|
size_t end_loc = fn->bytecode.size;
|
|
|
|
// Fix up jumps
|
|
uint32_t *cond_jmp, *yes_jmp;
|
|
cond_jmp = vector_ref(&fn->bytecode, cond_jmp_loc);
|
|
yes_jmp = vector_ref(&fn->bytecode, yes_jmp_loc);
|
|
|
|
*cond_jmp |= (no_loc - cond_jmp_loc) & 0xFFFFFF;
|
|
*yes_jmp |= (end_loc - yes_jmp_loc) & 0xFFFFFF;
|
|
return 0;
|
|
} else if (!strcmp(name, "while")) {
|
|
arg0 = car(tail); // condition
|
|
arg1 = cdr(tail); // list of expressions
|
|
assert(!null_q(arg1));
|
|
|
|
size_t begin_loc = fn->bytecode.size;
|
|
emit(fn, ctx, arg0);
|
|
size_t cond_jmp_loc = fn->bytecode.size;
|
|
emit_insn(fn, OP(OP_BF, 0));
|
|
|
|
for (struct node *item = arg1; item; item = cdr(item)) {
|
|
emit(fn, ctx, car(item));
|
|
}
|
|
|
|
// Jump back to the beginning
|
|
size_t end_jmp_loc = fn->bytecode.size;
|
|
ssize_t diff = (ssize_t) begin_loc - (ssize_t) end_jmp_loc;
|
|
emit_insn(fn, OP(OP_JMP, diff));
|
|
|
|
size_t end_loc = fn->bytecode.size;
|
|
uint32_t *cond_jmp;
|
|
cond_jmp = vector_ref(&fn->bytecode, cond_jmp_loc);
|
|
*cond_jmp |= (end_loc - cond_jmp_loc) & 0xFFFFFF;
|
|
return 0;
|
|
} else if (!strcmp(name, "list")) {
|
|
emit_insn(fn, OP(OP_LDNIL, 0));
|
|
emit_rev_cons(fn, ctx, tail);
|
|
return 0;
|
|
} else if (!strcmp(name, "use") ||
|
|
!strcmp(name, "export")) {
|
|
// Ignore
|
|
return 0;
|
|
}
|
|
|
|
return -1;
|
|
}
|
|
|
|
int emit_builtin_insn(struct function *fn, const char *name, int argc) {
|
|
if (!strcmp(name, "+")) {
|
|
for (int i = 1; i < argc; ++i) {
|
|
emit_insn(fn, OP(OP_ADD, 0));
|
|
}
|
|
return 0;
|
|
} else if (!strcmp(name, "-")) {
|
|
for (int i = 1; i < argc; ++i) {
|
|
emit_insn(fn, OP(OP_SUB, 0));
|
|
}
|
|
return 0;
|
|
} else if (!strcmp(name, "*")) {
|
|
for (int i = 1; i < argc; ++i) {
|
|
emit_insn(fn, OP(OP_MUL, 0));
|
|
}
|
|
return 0;
|
|
} else if (!strcmp(name, "/") && argc == 2) {
|
|
emit_insn(fn, OP(OP_DIV, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "%") && argc == 2) {
|
|
emit_insn(fn, OP(OP_MOD, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "cons") && argc == 2) {
|
|
emit_insn(fn, OP(OP_CONS, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "=") && argc == 2) {
|
|
emit_insn(fn, OP(OP_EQ, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "/=") && argc == 2) {
|
|
emit_insn(fn, OP(OP_NEQ, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, ">") && argc == 2) {
|
|
emit_insn(fn, OP(OP_GT, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, ">=") && argc == 2) {
|
|
emit_insn(fn, OP(OP_GE, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "<") && argc == 2) {
|
|
emit_insn(fn, OP(OP_LT, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "<=") && argc == 2) {
|
|
emit_insn(fn, OP(OP_LE, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "null?") && argc == 1) {
|
|
emit_insn(fn, OP(OP_ISZ, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "not") && argc == 1) {
|
|
emit_insn(fn, OP(OP_NOT, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "car") && argc == 1) {
|
|
emit_insn(fn, OP(OP_CAR, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "cdr") && argc == 1) {
|
|
emit_insn(fn, OP(OP_CDR, 0));
|
|
return 0;
|
|
} else if (!strcmp(name, "debug/trace") && argc == 1) {
|
|
emit_insn(fn, OP(OP_DEBUG, OP_DEBUG_TRACE));
|
|
return 0;
|
|
} else if (!strcmp(name, "debug/break")) {
|
|
emit_insn(fn, OP(OP_DEBUG, OP_DEBUG_BREAKPOINT));
|
|
return 0;
|
|
}
|
|
return -1;
|
|
}
|