1724 lines
61 KiB
C
1724 lines
61 KiB
C
#include "compile.h"
|
|
|
|
#include <ctype.h>
|
|
#include <stdlib.h>
|
|
#include <string.h>
|
|
#include <stdarg.h>
|
|
|
|
static ssize_t byte_compile_form_internal(CompileEnvironment *env,
|
|
AstNode *form, LispReg *target,
|
|
FILE *stream, CompileError **err);
|
|
|
|
static void push_error_raw(CompileError **list, CompileError *n) {
|
|
if (list) {
|
|
n->next = *list;
|
|
*list = n;
|
|
}
|
|
}
|
|
|
|
__attribute__((format(printf, 4, 5)))
|
|
static void push_error_at_ast(CompileError **list, AstNode *form,
|
|
CompileErrorType type, const char *fmt, ...) {
|
|
if (list) {
|
|
CompileError *err = malloc(sizeof(CompileError));
|
|
err->type = type;
|
|
err->context = ast_prin1_node_to_string(form, NULL);
|
|
va_list args;
|
|
va_start(args, fmt);
|
|
err->message = NULL;
|
|
vasprintf(&err->message, fmt, args);
|
|
va_end(args);
|
|
err->line = form->line;
|
|
err->col = form->col;
|
|
push_error_raw(list, err);
|
|
}
|
|
}
|
|
|
|
__attribute__((format(printf, 4, 5)))
|
|
static void push_error_with_ctx(CompileError **list, const char *ctx,
|
|
CompileErrorType type, const char *fmt, ...) {
|
|
if (list) {
|
|
CompileError *err = malloc(sizeof(CompileError));
|
|
err->type = type;
|
|
if (ctx) {
|
|
err->context = strdup(ctx);
|
|
} else {
|
|
err->context = NULL;
|
|
}
|
|
va_list args;
|
|
va_start(args, fmt);
|
|
err->message = NULL;
|
|
vasprintf(&err->message, fmt, args);
|
|
va_end(args);
|
|
err->line = 0; // no position information
|
|
err->col = 0;
|
|
push_error_raw(list, err);
|
|
}
|
|
}
|
|
|
|
CompileFormat COMPILE_FORMAT = COMPILE_FORMAT_BIN;
|
|
|
|
typedef enum {
|
|
ARG_U8,
|
|
ARG_U16,
|
|
ARG_U32,
|
|
ARG_U64,
|
|
ARG_I8,
|
|
ARG_I16,
|
|
ARG_I32,
|
|
ARG_I64,
|
|
ARG_REG,
|
|
ARG_STR,
|
|
ARG_BYTES,
|
|
ARG_DOUBLE,
|
|
ARG_BOOL,
|
|
} InstArgType;
|
|
|
|
static bool emit_next_arg_c(CompileError **err, FILE *stream,
|
|
InstArgType type, va_list args) {
|
|
if (type == ARG_STR || type == ARG_BYTES) {
|
|
size_t len;
|
|
if (type == ARG_BYTES) {
|
|
len = va_arg(args, size_t);
|
|
}
|
|
const char *val = va_arg(args, const char *);
|
|
if (type == ARG_STR) {
|
|
len = strlen(val);
|
|
}
|
|
size_t escaped_len;
|
|
char *escaped = ast_escape_string(val, len, &escaped_len);
|
|
fputc('"', stream);
|
|
fwrite(escaped, 1, escaped_len, stream);
|
|
fputc('"', stream);
|
|
free(escaped);
|
|
return true;
|
|
} else if (type == ARG_REG) {
|
|
LispRegType type = va_arg(args, int); // LispRegType promotes to int
|
|
if (type > N_REGISTTERS) {
|
|
push_error_with_ctx(err, NULL, COMPILE_ERROR,
|
|
"unknown register type: %ju", (uintmax_t) type);
|
|
return false;
|
|
}
|
|
uint32_t which = va_arg(args, uint32_t);
|
|
fprintf(stream, "%s%ju", REGISTER_NAMES[type], (uintmax_t) which);
|
|
return true;
|
|
} else if (type == ARG_DOUBLE) {
|
|
double value = va_arg(args, double);
|
|
fprintf(stream, "%f", value);
|
|
return true;
|
|
} else if (type == ARG_BOOL) {
|
|
uint32_t value = va_arg(args, uint32_t);
|
|
if (value) {
|
|
fprintf(stream, "true");
|
|
} else {
|
|
fprintf(stream, "false");
|
|
}
|
|
return true;
|
|
}
|
|
uint64_t val;
|
|
const char *format;
|
|
switch (type) {
|
|
case ARG_U8: // promoted
|
|
case ARG_U16: // promoted
|
|
case ARG_U32:
|
|
val = va_arg(args, uint32_t);
|
|
format = "%ju";
|
|
break;
|
|
case ARG_U64:
|
|
val = va_arg(args, uint64_t);
|
|
format = "%ju";
|
|
break;
|
|
case ARG_I8:
|
|
case ARG_I16:
|
|
case ARG_I32:
|
|
val = va_arg(args, uint32_t);
|
|
format = "%jd";
|
|
break;
|
|
case ARG_I64:
|
|
val = va_arg(args, uint64_t);
|
|
format = "%jd";
|
|
break;
|
|
default:
|
|
// shouldn't happen
|
|
abort();
|
|
break;
|
|
}
|
|
fprintf(stream, format, (uintmax_t) val);
|
|
return true;
|
|
}
|
|
|
|
static bool emit_next_arg_bin(CompileError **err, FILE *stream,
|
|
InstArgType type, va_list args) {
|
|
if (type == ARG_STR || type == ARG_BYTES) {
|
|
size_t len;
|
|
if (type == ARG_BYTES) {
|
|
len = va_arg(args, size_t);
|
|
}
|
|
const char *val = va_arg(args, const char *);
|
|
if (type == ARG_STR) {
|
|
len = strlen(val);
|
|
}
|
|
fwrite(&len, sizeof(len), 1, stream);
|
|
fwrite(val, 1, len, stream);
|
|
return true;
|
|
} else if (type == ARG_REG) {
|
|
LispRegType type = va_arg(args, int); // LispRegType promotes to int
|
|
if (type > N_REGISTTERS) {
|
|
push_error_with_ctx(err, NULL, COMPILE_ERROR,
|
|
"unknown register type: %ju", (uintmax_t) type);
|
|
return false;
|
|
}
|
|
uint32_t which = va_arg(args, uint32_t);
|
|
fwrite(&type, sizeof(type), 1, stream);
|
|
fwrite(&which, sizeof(which), 1, stream);
|
|
return true;
|
|
} else if (type == ARG_DOUBLE) {
|
|
double val = va_arg(args, double);
|
|
fwrite(&val, sizeof(val), 1, stream);
|
|
return true;
|
|
}
|
|
size_t size;
|
|
uint64_t val;
|
|
switch (type) {
|
|
case ARG_U8:
|
|
case ARG_BOOL:
|
|
case ARG_I8:
|
|
size = 8;
|
|
val = va_arg(args, uint32_t);
|
|
break;
|
|
case ARG_U16:
|
|
case ARG_I16:
|
|
size = 16;
|
|
val = va_arg(args, uint32_t);
|
|
break;
|
|
case ARG_U32:
|
|
case ARG_I32:
|
|
size = 32;
|
|
val = va_arg(args, uint32_t);
|
|
break;
|
|
case ARG_U64:
|
|
case ARG_I64:
|
|
size = 64;
|
|
val = va_arg(args, uint64_t);
|
|
break;
|
|
default:
|
|
// shouldn't happen
|
|
abort();
|
|
break;
|
|
}
|
|
fwrite(((void *) &val) + sizeof(uint64_t) - size, size, 1, stream);
|
|
return false;
|
|
}
|
|
|
|
// false on error, true on success
|
|
static bool emit_instruction(CompileError **err, FILE *stream,
|
|
LispInst inst, size_t nargs, ...) {
|
|
if (inst > N_INSTRUCTIONS) {
|
|
push_error_with_ctx(err, NULL, COMPILE_ERROR,
|
|
"unknown instruction: %ju", (intmax_t) inst);
|
|
return false;
|
|
}
|
|
switch (COMPILE_FORMAT) {
|
|
case COMPILE_FORMAT_ASM:
|
|
fprintf(stream, "%s%s", INSTRUCTION_NAMES[inst],
|
|
nargs ? " " : "");
|
|
break;
|
|
case COMPILE_FORMAT_BIN:
|
|
fwrite(&inst, sizeof(inst), 1, stream);
|
|
break;
|
|
}
|
|
bool success = true;
|
|
va_list args;
|
|
va_start(args, nargs);
|
|
for (size_t i = 0; i < nargs; ++i) {
|
|
InstArgType type = va_arg(args, InstArgType);
|
|
switch (COMPILE_FORMAT) {
|
|
case COMPILE_FORMAT_ASM:
|
|
success = emit_next_arg_c(err, stream, type, args);
|
|
if (i < nargs - 1) {
|
|
fprintf(stream, ", ");
|
|
}
|
|
break;
|
|
case COMPILE_FORMAT_BIN:
|
|
success = emit_next_arg_bin(err, stream, type, args);
|
|
break;
|
|
}
|
|
if (!success) {
|
|
break;
|
|
}
|
|
}
|
|
va_end(args);
|
|
if (COMPILE_FORMAT == COMPILE_FORMAT_ASM) {
|
|
fputc('\n', stream);
|
|
}
|
|
return success;
|
|
}
|
|
|
|
CompileError *compile_error_pop(CompileError **err) {
|
|
CompileError *retval = *err;
|
|
if (*err) {
|
|
*err = (*err)->next;
|
|
}
|
|
return retval;
|
|
}
|
|
|
|
void compile_error_free_one(CompileError *err) {
|
|
free(err->message);
|
|
free(err->context);
|
|
free(err);
|
|
}
|
|
|
|
void compile_error_free_all(CompileError **err) {
|
|
while (*err) {
|
|
CompileError *next = (*err)->next;
|
|
compile_error_free_one(*err);
|
|
*err = next;
|
|
}
|
|
}
|
|
|
|
void compile_format_error(CompileError *err, const char *file, FILE *stream) {
|
|
fprintf(stream, "error: ");
|
|
if (file) {
|
|
fprintf(stream, "%s: ", file);
|
|
}
|
|
if (err->line) {
|
|
fprintf(stream, "%zu:%zu:", err->line, err->col);
|
|
}
|
|
fprintf(stream, "%s", err->message);
|
|
if (err->context) {
|
|
fprintf(stream, ":\n%s\n", err->context);
|
|
} else {
|
|
fputc('\n', stream);
|
|
}
|
|
}
|
|
|
|
void destroy_function_entry(FunctionEntry *entry) {
|
|
free(entry->name);
|
|
free(entry->doc);
|
|
for (size_t i = 0; i < entry->nkeys; ++i) {
|
|
free(entry->keys[i]);
|
|
}
|
|
free(entry->keys);
|
|
}
|
|
|
|
void destroy_variable_entry(VariableEntry *entry) {
|
|
free(entry->name);
|
|
free(entry->doc);
|
|
}
|
|
|
|
void destroy_compile_lexenv(CompileLexenv *lexenv) {
|
|
for (size_t i = 0; i < lexenv->nsymbols; ++i) {
|
|
free(lexenv->symbols[i].name);
|
|
}
|
|
free(lexenv->symbols);
|
|
for (size_t i = 0; i < lexenv->nvars; ++i) {
|
|
free(lexenv->vars[i].name);
|
|
}
|
|
free(lexenv->vars);
|
|
free(lexenv);
|
|
}
|
|
|
|
static void environment_enter_lexenv(CompileEnvironment *env, bool inherit) {
|
|
CompileLexenv *n = malloc(sizeof(CompileLexenv));
|
|
n->vars = NULL;
|
|
n->nvars = 0;
|
|
n->symbols = NULL;
|
|
n->nsymbols = 0;
|
|
n->first_avaiable_saved = 0;
|
|
n->next = env->lexenv_stack;
|
|
if (inherit && env->lexenv_stack) {
|
|
n->first_avaiable_saved += env->lexenv_stack->first_avaiable_saved;
|
|
}
|
|
n->inherit = inherit;
|
|
env->lexenv_stack = n;
|
|
}
|
|
|
|
static void environment_leave_lexenv(CompileEnvironment *env) {
|
|
if (env->lexenv_stack) {
|
|
CompileLexenv *next = env->lexenv_stack->next;
|
|
destroy_compile_lexenv(env->lexenv_stack);
|
|
env->lexenv_stack = next;
|
|
}
|
|
}
|
|
|
|
CompileEnvironment *make_compile_environment() {
|
|
CompileEnvironment *env = malloc(sizeof(CompileEnvironment));
|
|
env->funcs = NULL;
|
|
env->nfuncs = 0;
|
|
env->vars = NULL;
|
|
env->nvars = 0;
|
|
env->lexenv_stack = NULL;
|
|
environment_enter_lexenv(env, false); // toplevel lexenv
|
|
return env;
|
|
}
|
|
|
|
void destroy_compile_environment(CompileEnvironment *env) {
|
|
for (size_t i = 0; i < env->nfuncs; ++i) {
|
|
destroy_function_entry(&env->funcs[i]);
|
|
}
|
|
for (size_t i = 0; i < env->nvars; ++i) {
|
|
destroy_variable_entry(&env->vars[i]);
|
|
}
|
|
while (env->lexenv_stack) {
|
|
CompileLexenv *next = env->lexenv_stack->next;
|
|
destroy_compile_lexenv(env->lexenv_stack);
|
|
env->lexenv_stack = next;
|
|
}
|
|
free(env);
|
|
}
|
|
|
|
static bool is_symbol_named(const char *name, AstNode *form) {
|
|
return form->type == AST_TYPE_SYMBOL &&
|
|
strcmp(name, ((AstSymbolNode *) form)->name) == 0;
|
|
}
|
|
|
|
static bool is_function_call(AstNode *form) {
|
|
return form->type == AST_TYPE_LIST && ((AstListNode *) form)->nchildren;
|
|
}
|
|
|
|
static bool is_function_call_named(const char *name, AstNode *form) {
|
|
return is_function_call(form) &&
|
|
is_symbol_named(name, ((AstListNode *) form)->children[0]);
|
|
}
|
|
|
|
static FunctionEntry *lookup_function(CompileEnvironment *env,
|
|
AstSymbolNode *name) {
|
|
for (size_t i = 0; i < env->nfuncs; ++i) {
|
|
FunctionEntry *cur = &env->funcs[i];
|
|
if (cur->name_len == name->name_length &&
|
|
strcmp(cur->name, name->name) == 0) {
|
|
return cur;
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
static VariableEntry *lookup_variable(CompileEnvironment *env,
|
|
AstSymbolNode *name) {
|
|
for (size_t i = 0; i < env->nvars; ++i) {
|
|
VariableEntry *cur = &env->vars[i];
|
|
if (cur->name_len == name->name_length &&
|
|
strcmp(cur->name, name->name) == 0) {
|
|
return cur;
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
static bool is_property_symbol(AstNode *form) {
|
|
return form->type == AST_TYPE_SYMBOL &&
|
|
((AstSymbolNode *) form)->is_property;
|
|
}
|
|
|
|
static char *copy_symbol_name(AstSymbolNode *sym) {
|
|
char *buf = malloc(sym->name_length + 1);
|
|
memcpy(buf, sym->name, sym->name_length + 1);
|
|
return buf;
|
|
}
|
|
|
|
static bool function_key_ok(AstSymbolNode *key, FunctionEntry *func) {
|
|
if (func->allow_other_keys) {
|
|
return true;
|
|
}
|
|
const char *name = key->is_property ? key->name + 1 : key->name;
|
|
for (size_t i = 0; i < func->nkeys; ++i) {
|
|
if (strcmp(name, func->keys[i]) == 0) {
|
|
return true;
|
|
}
|
|
}
|
|
return false;
|
|
}
|
|
|
|
// return false only if there is an error (not a warning)
|
|
static bool function_arguments_ok(AstListNode *form, FunctionEntry *func,
|
|
CompileError **err) {
|
|
bool was_ok = true;
|
|
size_t npositional = form->nchildren - 1;
|
|
bool had_key = false;
|
|
if (func->nkeys) {
|
|
for (size_t i = 1; i < form->nchildren; ++i) {
|
|
if (is_property_symbol(form->children[i])) {
|
|
if (!function_key_ok((AstSymbolNode *) form->children[i], func)) {
|
|
push_error_at_ast(err, form->children[i], COMPILE_WARNING,
|
|
"unknown key for function %s", func->name);
|
|
}
|
|
if (i == form->nchildren - 1) {
|
|
push_error_at_ast(err, form->children[i], COMPILE_ERROR,
|
|
"no value provided to key");
|
|
was_ok = false;
|
|
}
|
|
had_key = true;
|
|
// skip next arg
|
|
++i;
|
|
npositional -= 2;
|
|
} else if (had_key) {
|
|
// positional argument after key argument
|
|
was_ok = false;
|
|
}
|
|
}
|
|
}
|
|
if (npositional < func->nrequired) {
|
|
push_error_at_ast(err, (AstNode *) form, COMPILE_ERROR,
|
|
"function expects at least %zu argument(s), got %zu",
|
|
func->nrequired, npositional);
|
|
was_ok = false;
|
|
} else if (!func->has_rest && npositional > func->nrequired + func->noptional) {
|
|
push_error_at_ast(err, (AstNode *)form, COMPILE_ERROR,
|
|
"function expects at most %zu argument(s), got %zu",
|
|
func->nrequired + func->noptional, npositional);
|
|
was_ok = false;
|
|
}
|
|
return was_ok;
|
|
}
|
|
|
|
static void intern_in_lexenv(CompileLexenv *lexenv, const char *name,
|
|
LispReg *reg) {
|
|
if (lexenv) {
|
|
lexenv->symbols = realloc(lexenv->symbols, sizeof(*lexenv->symbols)
|
|
* ++(lexenv->nsymbols));
|
|
lexenv->symbols[lexenv->nsymbols - 1].name = strdup(name);
|
|
lexenv->symbols[lexenv->nsymbols - 1].reg = *reg;
|
|
}
|
|
}
|
|
|
|
static LispReg *lookup_symbol_reg(CompileEnvironment *env, const char *name) {
|
|
CompileLexenv *lexenv = env->lexenv_stack;
|
|
while (lexenv) {
|
|
for (size_t i = 0; i < lexenv->nsymbols; ++i) {
|
|
if (strcmp(name, lexenv->symbols[i].name) == 0) {
|
|
return &lexenv->symbols[i].reg;
|
|
}
|
|
}
|
|
if (lexenv->inherit) {
|
|
lexenv = lexenv->next;
|
|
} else {
|
|
lexenv = NULL;
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
static LispReg *lookup_local_var(CompileEnvironment *env, const char *name) {
|
|
CompileLexenv *lexenv = env->lexenv_stack;
|
|
while (lexenv) {
|
|
for (size_t i = 0; i < lexenv->nvars; ++i) {
|
|
if (strcmp(name, lexenv->vars[i].name) == 0) {
|
|
return &lexenv->vars[i].reg;
|
|
}
|
|
}
|
|
if (lexenv->inherit) {
|
|
lexenv = lexenv->next;
|
|
} else {
|
|
lexenv = NULL;
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
static void next_open_saved_reg(CompileEnvironment *env, LispReg *out) {
|
|
out->type = REG_SAVED;
|
|
if (env->lexenv_stack) {
|
|
out->which = env->lexenv_stack->first_avaiable_saved++;
|
|
} else {
|
|
out->which = 0;
|
|
}
|
|
}
|
|
|
|
// return number of instructions emitted, or -1 on error
|
|
static ssize_t intern_to_register(CompileEnvironment *env, FILE *stream,
|
|
const char *name, size_t name_len,
|
|
LispReg *target, CompileError **err) {
|
|
CompileLexenv *lexenv = env->lexenv_stack;
|
|
LispReg *cur_reg = lookup_symbol_reg(env, name);
|
|
if (cur_reg) {
|
|
if (SAME_REG(cur_reg, target)) {
|
|
return 0;
|
|
}
|
|
if (!emit_instruction(err, stream, INST_MOV, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, cur_reg->type, cur_reg->which)) {
|
|
return -1;
|
|
}
|
|
} else {
|
|
if (!emit_instruction(err, stream, INST_INTERN_LIT, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_BYTES, name_len, name)) {
|
|
return -1;
|
|
}
|
|
if (target->type == REG_SAVED) {
|
|
intern_in_lexenv(lexenv, name, target);
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
static ssize_t intern_and_save(CompileEnvironment *env, FILE *stream,
|
|
const char *name, size_t name_len,
|
|
LispReg *reg, CompileError **err) {
|
|
CompileLexenv *lexenv = env->lexenv_stack;
|
|
LispReg *cur_reg = lookup_symbol_reg(env, name);
|
|
if (cur_reg) {
|
|
*reg = *cur_reg;
|
|
return 0;
|
|
}
|
|
next_open_saved_reg(env, reg);
|
|
if (!emit_instruction(err, stream, INST_INTERN_LIT, 2,
|
|
ARG_REG, reg->type, reg->which,
|
|
ARG_BYTES, name_len, name)) {
|
|
return -1;
|
|
}
|
|
intern_in_lexenv(lexenv, name, reg);
|
|
return 1;
|
|
}
|
|
|
|
static void add_variable_to_lexenv(CompileLexenv *lexenv, const char *name,
|
|
LispReg *reg) {
|
|
for (size_t i = 0; i < lexenv->nvars; ++i) {
|
|
if (strcmp(name, lexenv->vars[i].name) == 0) {
|
|
lexenv->vars[i].reg = *reg;
|
|
return;
|
|
}
|
|
}
|
|
lexenv->vars = realloc(lexenv->vars, sizeof(*lexenv->vars) *
|
|
++lexenv->nvars);
|
|
lexenv->vars[lexenv->nvars - 1].name = strdup(name);
|
|
lexenv->vars[lexenv->nvars - 1].reg = *reg;
|
|
}
|
|
|
|
static ssize_t maybe_save_argument_reg(CompileEnvironment *env,
|
|
LispReg *arg_reg, FILE *stream,
|
|
CompileError **err) {
|
|
LispReg new_reg;
|
|
CompileLexenv *lexenv = env->lexenv_stack;
|
|
while (lexenv) {
|
|
for (size_t i = 0; i < lexenv->nvars; ++i) {
|
|
if (SAME_REG(&lexenv->vars[i].reg, arg_reg)) {
|
|
next_open_saved_reg(env, &new_reg);
|
|
add_variable_to_lexenv(env->lexenv_stack, lexenv->vars[i].name,
|
|
&new_reg);
|
|
return emit_instruction(err, stream, INST_MOV, 2,
|
|
ARG_REG, new_reg.type, new_reg.which,
|
|
ARG_REG, arg_reg->type, arg_reg->which)
|
|
? 1 : -1;
|
|
}
|
|
}
|
|
if (lexenv->inherit) {
|
|
lexenv = lexenv->next;
|
|
} else {
|
|
lexenv = NULL;
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
static FunctionEntry *get_or_make_function_entry(CompileEnvironment *env,
|
|
AstSymbolNode *name,
|
|
bool warn_on_redef,
|
|
CompileError **err,
|
|
AstNode *form) {
|
|
for (size_t i = 0; i < env->nfuncs; ++i) {
|
|
if (name->name_length == env->funcs[i].name_len &&
|
|
strcmp(env->funcs[i].name, name->name) == 0) {
|
|
if (warn_on_redef) {
|
|
push_error_at_ast(err, form, COMPILE_WARNING,
|
|
"function already defined");
|
|
}
|
|
return &env->funcs[i];
|
|
}
|
|
}
|
|
env->funcs = realloc(env->funcs, sizeof(FunctionEntry) * ++env->nfuncs);
|
|
FunctionEntry *ne = &env->funcs[env->nfuncs - 1];
|
|
ne->name = strdup(name->name);
|
|
ne->name_len = name->name_length;
|
|
ne->line = form->line;
|
|
ne->col = form->col;
|
|
return ne;
|
|
}
|
|
|
|
// true on success, false on error
|
|
static bool parse_function_lambda_list(AstListNode *list, FunctionEntry *entry,
|
|
CompileError **err) {
|
|
entry->allow_other_keys = false;
|
|
entry->keys = NULL;
|
|
entry->nkeys = 0;
|
|
entry->required = NULL;
|
|
entry->nrequired = 0;
|
|
entry->optional = NULL;
|
|
entry->noptional = 0;
|
|
entry->has_rest = false;
|
|
if (list->parent.type == AST_TYPE_NULL) {
|
|
return true;
|
|
}
|
|
bool found_opt = false;
|
|
bool found_rest = false;
|
|
bool found_key = false;
|
|
bool found_allow_other_keys = false;
|
|
// 0 = req, 1 = opt, 2 = key, 3 = rest
|
|
int cur_mode = 0;
|
|
for (size_t i = 0; i < list->nchildren; ++i) {
|
|
if (list->children[i]->type != AST_TYPE_SYMBOL) {
|
|
char *printed_rep = ast_prin1_node_to_string(list->children[i], NULL);
|
|
push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
|
|
"function argument not a symbol %s", printed_rep);
|
|
free(printed_rep);
|
|
return false;
|
|
}
|
|
AstSymbolNode *arg = (AstSymbolNode *) list->children[i];
|
|
if (is_symbol_named("&optional", (AstNode *) arg)) {
|
|
if (found_opt) {
|
|
push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
|
|
"&optional appeared more than once");
|
|
return false;
|
|
}
|
|
found_opt = true;
|
|
cur_mode = 1;
|
|
} else if (is_symbol_named("&rest", (AstNode *) arg)) {
|
|
if (found_rest) {
|
|
push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
|
|
"&rest appeared more than once");
|
|
return false;
|
|
}
|
|
found_rest = true;
|
|
cur_mode = 3;
|
|
} else if (is_symbol_named("&key", (AstNode *) arg)) {
|
|
if (found_key) {
|
|
push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
|
|
"&key appeared more than once");
|
|
return false;
|
|
}
|
|
found_key = true;
|
|
cur_mode = 2;
|
|
} else if (is_symbol_named("&allow-other-keys", (AstNode *) arg)) {
|
|
if (found_allow_other_keys) {
|
|
push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
|
|
"&allow-other-keys appeared more than once");
|
|
return false;
|
|
}
|
|
found_allow_other_keys = true;
|
|
} else if (cur_mode == 3) { // rest
|
|
if (entry->has_rest) {
|
|
push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
|
|
"there can only be 1 &rest variable");
|
|
return false;
|
|
}
|
|
entry->has_rest = true;
|
|
entry->rest = copy_symbol_name(arg);
|
|
} else {
|
|
size_t *target_len;
|
|
char ***target_var;
|
|
switch (cur_mode) {
|
|
case 0: // req
|
|
target_len = &entry->nrequired;
|
|
target_var = &entry->required;
|
|
break;
|
|
case 1: // opt
|
|
target_len = &entry->noptional;
|
|
target_var = &entry->optional;
|
|
break;
|
|
case 2: // key
|
|
target_len = &entry->nkeys;
|
|
target_var = &entry->keys;
|
|
break;
|
|
}
|
|
*target_var = realloc(*target_var, sizeof(char *) * ++(*target_len));
|
|
(*target_var)[*target_len - 1] = copy_symbol_name(arg);
|
|
}
|
|
}
|
|
if (!found_key && found_allow_other_keys) {
|
|
push_error_at_ast(err, (AstNode *)list, COMPILE_WARNING,
|
|
"&allow-other-keys appeared without &key");
|
|
}
|
|
return true;
|
|
}
|
|
|
|
static FunctionEntry *parse_and_add_function(CompileEnvironment *env,
|
|
AstListNode *form,
|
|
CompileError **err) {
|
|
if (form->nchildren < 2 || (form->children[2]->type != AST_TYPE_LIST &&
|
|
(form->children[2]->type != AST_TYPE_NULL))) {
|
|
push_error_at_ast(err, (AstNode *) form, COMPILE_ERROR,
|
|
"invalid arguments to defun");
|
|
return NULL;
|
|
}
|
|
AstSymbolNode *name = (AstSymbolNode *) form->children[1];
|
|
FunctionEntry *entry = get_or_make_function_entry(env, name, true, err,
|
|
(AstNode *) form);
|
|
if (!parse_function_lambda_list((AstListNode *) form->children[2],
|
|
entry, err)) {
|
|
return NULL;
|
|
}
|
|
if (form->nchildren >= 4 && form->children[3]->type == AST_TYPE_STRING) {
|
|
AstStringNode *doc_node = (AstStringNode *) form->children[3];
|
|
entry->doc_len = doc_node->length;
|
|
entry->doc = malloc(doc_node->length + 1);
|
|
memcpy(entry->doc, doc_node->value, doc_node->length + 1);
|
|
}
|
|
return entry;
|
|
}
|
|
|
|
static ssize_t save_arg_register(CompileEnvironment *env, uint32_t which_arg,
|
|
LispReg *target, FILE *stream, CompileError **err) {
|
|
next_open_saved_reg(env, target);
|
|
return emit_instruction(err, stream, INST_MOV, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, REG_ARG, which_arg);
|
|
}
|
|
|
|
static ssize_t emit_generic_arg_list(CompileEnvironment *env, AstNode **args,
|
|
size_t arg_count, bool ignore_ret_vals,
|
|
FILE *stream, CompileError **err) {
|
|
ssize_t ec = 0;
|
|
uint32_t first_saved_arg;
|
|
if (ignore_ret_vals) {
|
|
first_saved_arg = env->first_available_val;
|
|
} else {
|
|
first_saved_arg = env->lexenv_stack->first_avaiable_saved;
|
|
}
|
|
size_t nused_saved = 0;
|
|
// do these first because they clobber the arg registers, so we need to save
|
|
// their output
|
|
for (size_t i = 0; i < arg_count; ++i) {
|
|
if (!args[i]) {
|
|
continue;
|
|
}
|
|
LispReg reg = {
|
|
.type = REG_SAVED,
|
|
.which = first_saved_arg + nused_saved,
|
|
};
|
|
switch (args[i]->type) {
|
|
case AST_TYPE_LIST:
|
|
case AST_TYPE_VECTOR:
|
|
case AST_TYPE_QUOTE: {
|
|
if (!ignore_ret_vals) {
|
|
env->lexenv_stack->first_avaiable_saved = reg.which + 1;
|
|
}
|
|
++nused_saved;
|
|
ssize_t rv = byte_compile_form_internal(env, args[i],
|
|
ignore_ret_vals ? NULL : ®,
|
|
stream, err);
|
|
if (rv < 0) {
|
|
ec = -1;
|
|
goto done;
|
|
}
|
|
ec += rv;
|
|
}
|
|
break;
|
|
default:
|
|
break;
|
|
}
|
|
}
|
|
if (!ignore_ret_vals) {
|
|
nused_saved = 0;
|
|
for (size_t i = 0; i < arg_count; ++i) {
|
|
LispReg reg = {
|
|
.type = REG_ARG,
|
|
.which = i,
|
|
};
|
|
ec += maybe_save_argument_reg(env, ®, stream, err);
|
|
if (!args[i]) {
|
|
emit_instruction(err, stream, INST_NIL, 1,
|
|
ARG_REG, reg.type, reg.which);
|
|
++ec;
|
|
continue;
|
|
}
|
|
switch (args[i]->type) {
|
|
case AST_TYPE_LIST:
|
|
case AST_TYPE_VECTOR:
|
|
case AST_TYPE_QUOTE:
|
|
emit_instruction(err, stream, INST_MOV, 2,
|
|
ARG_REG, reg.type, reg.which,
|
|
ARG_REG, REG_SAVED, first_saved_arg +
|
|
nused_saved++);
|
|
++ec;
|
|
break;
|
|
case AST_TYPE_SYMBOL:
|
|
case AST_TYPE_INT:
|
|
case AST_TYPE_FLOAT:
|
|
case AST_TYPE_STRING:
|
|
case AST_TYPE_NULL: {
|
|
ssize_t rv = byte_compile_form_internal(env, args[i], ®,
|
|
stream, err);
|
|
if (rv < 0) {
|
|
ec = -1;
|
|
goto done;
|
|
}
|
|
ec += rv;
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
done:
|
|
env->lexenv_stack->first_avaiable_saved = first_saved_arg;
|
|
return ec;
|
|
}
|
|
|
|
static void add_lambda_list_to_lexenv(CompileEnvironment *env,
|
|
FunctionEntry *entry,
|
|
FILE *stream,
|
|
CompileError **err) {
|
|
for (size_t i = 0; i < entry->nrequired; ++i) {
|
|
LispReg target = {
|
|
.type = REG_ARG,
|
|
.which = i,
|
|
};
|
|
add_variable_to_lexenv(env->lexenv_stack, entry->required[i], &target);
|
|
}
|
|
for (size_t i = 0; i < entry->noptional; ++i) {
|
|
uint32_t pos = i + entry->nrequired;
|
|
LispReg target = {
|
|
.type = REG_ARG,
|
|
.which = pos,
|
|
};
|
|
add_variable_to_lexenv(env->lexenv_stack, entry->optional[i], &target);
|
|
}
|
|
for (size_t i = 0; i < entry->nkeys; ++i) {
|
|
size_t pos = i + entry->nrequired + entry->noptional;
|
|
LispReg target = {
|
|
.type = REG_ARG,
|
|
.which = pos,
|
|
};
|
|
add_variable_to_lexenv(env->lexenv_stack, entry->keys[i], &target);
|
|
}
|
|
if (entry->rest) {
|
|
size_t pos = entry->nrequired + entry->noptional + entry->nkeys;
|
|
LispReg target = {
|
|
.type = REG_ARG,
|
|
.which = pos,
|
|
};
|
|
add_variable_to_lexenv(env->lexenv_stack, entry->rest, &target);
|
|
}
|
|
}
|
|
|
|
static ssize_t emit_newfunction_for_entry(CompileEnvironment *env,
|
|
FunctionEntry *entry,
|
|
size_t int_forms, LispReg *target,
|
|
FILE *stream, CompileError **err) {
|
|
ssize_t total_insts = entry->nkeys + 1;
|
|
for (size_t i = 0; i < entry->nkeys; ++i) {
|
|
LispReg arg_reg = {
|
|
.type = REG_ARG,
|
|
.which = i,
|
|
};
|
|
total_insts += maybe_save_argument_reg(env, &arg_reg, stream, err);
|
|
emit_instruction(err, stream, INST_INTERN_LIT, 2,
|
|
ARG_REG, arg_reg.type, arg_reg.which,
|
|
ARG_STR, entry->keys[i]);
|
|
}
|
|
emit_instruction(err, stream, INST_NEWFUNCTION_LIT, 7,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_U32, (uint32_t) entry->nrequired,
|
|
ARG_U32, (uint32_t) entry->noptional,
|
|
ARG_U32, (uint32_t) entry->nkeys,
|
|
ARG_BOOL, (uint8_t) entry->allow_other_keys,
|
|
ARG_BOOL, (uint8_t) entry->has_rest,
|
|
ARG_U64, (uint64_t) int_forms);
|
|
return total_insts;
|
|
}
|
|
|
|
// return the form at ret_index
|
|
static ssize_t compile_multi_form_internal(CompileEnvironment *env,
|
|
ssize_t ret_index, AstNode **forms,
|
|
size_t nforms, LispReg *target,
|
|
FILE *stream, CompileError **err) {
|
|
LispReg save_ret_reg;
|
|
ssize_t int_nforms = 0;
|
|
for (size_t i = 0; i < nforms; ++i) {
|
|
ssize_t ec;
|
|
if (i == ret_index && ret_index >= nforms - 1) {
|
|
ec = byte_compile_form_internal(env, forms[i], target,
|
|
stream, err);
|
|
} else if (i == ret_index) {
|
|
next_open_saved_reg(env, &save_ret_reg);
|
|
ec = byte_compile_form_internal(env, forms[i],
|
|
target ? &save_ret_reg : NULL,
|
|
stream, err);
|
|
} else {
|
|
ec = byte_compile_form_internal(env, forms[i], NULL,
|
|
stream, err);
|
|
}
|
|
if (ec < 0) {
|
|
return -1;
|
|
}
|
|
int_nforms += ec;
|
|
}
|
|
if (ret_index < nforms - 1 && target) {
|
|
++int_nforms;
|
|
emit_instruction(err, stream, INST_MOV, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, save_ret_reg.type, save_ret_reg.which);
|
|
}
|
|
return int_nforms;
|
|
}
|
|
|
|
// might want to clean this up at some point
|
|
static ssize_t compile_defun_call(CompileEnvironment *env, AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
AstSymbolNode *name = (AstSymbolNode *) form->children[1];
|
|
FunctionEntry *entry = lookup_function(env, name);
|
|
if (!entry && !(entry = parse_and_add_function(env, form, err))) {
|
|
return -1;
|
|
}
|
|
size_t first_form = 3;
|
|
if (form->nchildren >= 4 && form->children[3]->type == AST_TYPE_STRING) {
|
|
++first_form;
|
|
}
|
|
size_t internal_len = 0;
|
|
char *internal_code = NULL;
|
|
FILE *int_stream = open_memstream(&internal_code, &internal_len);
|
|
environment_enter_lexenv(env, false);
|
|
add_lambda_list_to_lexenv(env, entry, int_stream, err);
|
|
size_t nchild_forms = form->nchildren - first_form;
|
|
LispReg ret_val_target = {
|
|
.type = REG_RET,
|
|
.which = 0,
|
|
};
|
|
ssize_t int_nforms =
|
|
compile_multi_form_internal(env, nchild_forms - 1, form->children + first_form,
|
|
nchild_forms, &ret_val_target, int_stream, err);
|
|
if (int_nforms < 0) {
|
|
goto compile_error;
|
|
}
|
|
environment_leave_lexenv(env);
|
|
fclose(int_stream);
|
|
LispReg backup_target = {
|
|
.type = REG_VAL,
|
|
.which = env->first_available_val,
|
|
};
|
|
if (!target) {
|
|
target = &backup_target;
|
|
}
|
|
ssize_t surround_nforms = 0;
|
|
surround_nforms += emit_newfunction_for_entry(env, entry,
|
|
int_nforms + (int_nforms ? 2 : 0),
|
|
target, stream, err);
|
|
if (int_nforms) {
|
|
emit_instruction(err, stream, INST_ENTER_LEXENV, 1,
|
|
ARG_U64, (uint64_t) int_nforms + 1);
|
|
emit_instruction(err, stream, INST_ENTER_BLOCK, 2,
|
|
ARG_BYTES, entry->name_len, entry->name,
|
|
ARG_U64, (uint64_t) int_nforms);
|
|
fwrite(internal_code, 1, internal_len, stream);
|
|
surround_nforms += 2;
|
|
}
|
|
free(internal_code);
|
|
LispReg name_reg;
|
|
surround_nforms += intern_and_save(env, stream, entry->name,
|
|
entry->name_len, &name_reg, err);
|
|
emit_instruction(err, stream, INST_SET_FUNCTION, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, name_reg.type, name_reg.which);
|
|
return int_nforms + surround_nforms + 6;
|
|
compile_error:
|
|
fclose(int_stream);
|
|
free(internal_code);
|
|
return -1;
|
|
}
|
|
|
|
static ssize_t compile_devar_call(CompileEnvironment *env, AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
return 0;
|
|
}
|
|
|
|
static ssize_t compile_progn_call(CompileEnvironment *env, AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
if (form->nchildren == 1 && target) {
|
|
return emit_instruction(err, stream, INST_NIL, 1,
|
|
ARG_REG, target->type, target->which) ? 1 : -1;
|
|
} else if (form->nchildren > 1){
|
|
return compile_multi_form_internal(env, form->nchildren - 1,
|
|
form->children + 1,
|
|
form->nchildren - 1, target,
|
|
stream, err);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
static ssize_t compile_if_call(CompileEnvironment *env, AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
if (form->nchildren == 1) {
|
|
push_error_at_ast(err, (AstNode *) form, COMPILE_ERROR,
|
|
"no condition for if form");
|
|
return -1;
|
|
}
|
|
LispReg cond_reg = {
|
|
.type = REG_VAL,
|
|
.which = env->first_available_val,
|
|
};
|
|
ssize_t total_ec = 0;
|
|
ssize_t ec;
|
|
ec = byte_compile_form_internal(env, form->children[1],
|
|
form->nchildren == 2 ? NULL : &cond_reg,
|
|
stream, err);
|
|
if (ec < 0) {
|
|
return -1;
|
|
}
|
|
total_ec += ec;
|
|
if (form->nchildren == 2) {
|
|
if (target) {
|
|
emit_instruction(err, stream, INST_NIL, 1,
|
|
ARG_REG, target->type, target->which);
|
|
++total_ec;
|
|
}
|
|
return total_ec;
|
|
}
|
|
char *true_bytes;
|
|
size_t true_len;
|
|
size_t true_ninst = 0;
|
|
FILE *true_stream = open_memstream(&true_bytes, &true_len);
|
|
true_ninst = byte_compile_form_internal(env, form->children[2], target,
|
|
true_stream, err);
|
|
fclose(true_stream);
|
|
if (true_ninst < 0) {
|
|
free(true_bytes);
|
|
return -1;
|
|
}
|
|
total_ec += true_ninst;
|
|
emit_instruction(err, stream, INST_CJMP, 2,
|
|
ARG_REG, cond_reg.type, cond_reg.which,
|
|
ARG_I64, (int64_t) true_ninst + 1);
|
|
++total_ec;
|
|
fwrite(true_bytes, 1, true_len, stream);
|
|
free(true_bytes);
|
|
char *false_bytes;
|
|
size_t false_len;
|
|
size_t false_ninst = 0;
|
|
FILE *false_stream = open_memstream(&false_bytes, &false_len);
|
|
size_t false_nforms = form->nchildren - 3;
|
|
false_ninst = compile_multi_form_internal(env, false_nforms - 1,
|
|
form->children + 3, false_nforms,
|
|
target, false_stream, err);
|
|
fclose(false_stream);
|
|
if (false_ninst < 0) {
|
|
free(false_bytes);
|
|
return -1;
|
|
}
|
|
total_ec += false_ninst;
|
|
emit_instruction(err, stream, INST_JMP, 1,
|
|
ARG_I64, (int64_t) false_ninst);
|
|
++total_ec;
|
|
fwrite(false_bytes, 1, false_len, stream);
|
|
free(false_bytes);
|
|
return total_ec;
|
|
}
|
|
|
|
static bool inst_func_eq(const char *func, const char *inst) {
|
|
while (*func && *inst) {
|
|
if (!(*func == '-' && *inst == '_') &&
|
|
tolower(*func) != tolower(*inst)) {
|
|
return false;
|
|
}
|
|
++func;
|
|
++inst;
|
|
}
|
|
return !*func && !*inst;
|
|
}
|
|
|
|
static LispInst find_instruction_by_func_name(const char *name) {
|
|
for (size_t i = 0; i < N_INSTRUCTIONS; ++i) {
|
|
if (inst_func_eq(name, INSTRUCTION_NAMES[i])) {
|
|
return i;
|
|
}
|
|
}
|
|
return N_INSTRUCTIONS;
|
|
}
|
|
|
|
static ssize_t compile_list_like_call(CompileEnvironment *env, AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
AstSymbolNode *name = (AstSymbolNode *) form->children[0];
|
|
LispInst inst = find_instruction_by_func_name(name->name);
|
|
if (inst >= N_INSTRUCTIONS) {
|
|
return -1;
|
|
}
|
|
ssize_t ec = emit_generic_arg_list(env, form->children + 1,
|
|
form->nchildren - 1, !target, stream, err);
|
|
if (target) {
|
|
ec += emit_instruction(err, stream, inst, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_U64, (uint64_t) form->nchildren - 1);
|
|
}
|
|
return ec;
|
|
}
|
|
|
|
static ssize_t compile_special_binary_func_call(CompileEnvironment *env,
|
|
AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
AstSymbolNode *name = (AstSymbolNode *) form->children[0];
|
|
if (form->nchildren != 3) {
|
|
push_error_at_ast(err, (AstNode *)form, COMPILE_ERROR,
|
|
"%s expects exactly 2 arguments", name->name);
|
|
}
|
|
LispInst inst = find_instruction_by_func_name(name->name);
|
|
ssize_t arg_nforms = emit_generic_arg_list(env, form->children + 1,
|
|
form->nchildren - 1, !target,
|
|
stream, err);
|
|
if (target) {
|
|
emit_instruction(err, stream, inst, 3,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, REG_ARG, (uint32_t) 0,
|
|
ARG_REG, REG_ARG, (uint32_t) 1);
|
|
++arg_nforms;
|
|
}
|
|
return arg_nforms;
|
|
}
|
|
|
|
static ssize_t compile_special_unary_func_call(CompileEnvironment *env,
|
|
AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
AstSymbolNode *name = (AstSymbolNode *) form->children[0];
|
|
if (form->nchildren != 2) {
|
|
push_error_at_ast(err, (AstNode *)form, COMPILE_ERROR,
|
|
"%s expects exactly 1 argument", name->name);
|
|
}
|
|
LispInst inst = find_instruction_by_func_name(name->name);
|
|
LispReg temp_reg = {
|
|
.type = REG_VAL,
|
|
.which = env->first_available_val,
|
|
};
|
|
ssize_t arg_nforms = byte_compile_form_internal(env, form->children[1],
|
|
!target ? NULL : &temp_reg,
|
|
stream, err);
|
|
if (target) {
|
|
emit_instruction(err, stream, inst, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, temp_reg.type, temp_reg.which);
|
|
++arg_nforms;
|
|
}
|
|
return arg_nforms;
|
|
}
|
|
|
|
static ssize_t compile_math_comparison_call(CompileEnvironment *env, AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
AstSymbolNode *name = (AstSymbolNode *) form->children[0];
|
|
if (form->nchildren != 3) {
|
|
push_error_at_ast(err, (AstNode *)form, COMPILE_ERROR,
|
|
"%s expects exactly 2 argument", name->name);
|
|
}
|
|
const char *real_name;
|
|
if (name->name_length == 1) {
|
|
switch (*name->name) {
|
|
case '<':
|
|
real_name = "NUM_LT";
|
|
break;
|
|
case '=':
|
|
real_name = "NUM_EQ";
|
|
break; case '>':
|
|
real_name = "NUM_GT";
|
|
break;
|
|
}
|
|
} else if (*name->name == '<') {
|
|
real_name = "NUM_LE";
|
|
} else if (*name->name == '>') {
|
|
real_name = "NUM_GE";
|
|
}
|
|
LispInst inst = find_instruction_by_func_name(real_name);
|
|
ssize_t arg_nforms = emit_generic_arg_list(env, form->children + 1,
|
|
form->nchildren - 1, !target,
|
|
stream, err);
|
|
if (target) {
|
|
emit_instruction(err, stream, inst, 3,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, REG_ARG, (uint32_t) 0,
|
|
ARG_REG, REG_ARG, (uint32_t) 1);
|
|
++arg_nforms;
|
|
}
|
|
return arg_nforms;
|
|
}
|
|
|
|
static ssize_t compile_math_arithmatic_call(CompileEnvironment *env, AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
const char *real_name;
|
|
AstSymbolNode *name = (AstSymbolNode *) form->children[0];
|
|
switch (*name->name) {
|
|
case '+':
|
|
real_name = "add";
|
|
break;
|
|
case '-':
|
|
real_name = "sub";
|
|
break;
|
|
case '*':
|
|
real_name = "mul";
|
|
break;
|
|
case '/':
|
|
real_name = "div";
|
|
break;
|
|
}
|
|
LispInst inst = find_instruction_by_func_name(real_name);
|
|
ssize_t ec = emit_generic_arg_list(env, form->children + 1,
|
|
form->nchildren - 1, !target, stream, err);
|
|
if (target) {
|
|
ec += emit_instruction(err, stream, inst, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_U64, (uint64_t) form->nchildren - 1);
|
|
}
|
|
return ec;
|
|
}
|
|
|
|
static const struct {
|
|
const char *name;
|
|
ssize_t (*handler)(CompileEnvironment *env, AstListNode *form,
|
|
LispReg *target, FILE *stream, CompileError **err);
|
|
} NATIVE_FUNCTIONS[] = {
|
|
{"defun", compile_defun_call},
|
|
{"devar", compile_devar_call},
|
|
{"progn", compile_progn_call},
|
|
{"if", compile_if_call},
|
|
|
|
{"list", compile_list_like_call},
|
|
{"vector", compile_list_like_call},
|
|
|
|
{"+", compile_math_arithmatic_call},
|
|
{"-", compile_math_arithmatic_call},
|
|
{"*", compile_math_arithmatic_call},
|
|
{"/", compile_math_arithmatic_call},
|
|
|
|
{"<=", compile_math_comparison_call},
|
|
{"<", compile_math_comparison_call},
|
|
{"=", compile_math_comparison_call},
|
|
{">=", compile_math_comparison_call},
|
|
{">", compile_math_comparison_call},
|
|
|
|
{"eq", compile_special_binary_func_call},
|
|
{"int-div", compile_special_binary_func_call},
|
|
{"mod", compile_special_binary_func_call},
|
|
{"pow", compile_special_binary_func_call},
|
|
{"bitand", compile_special_binary_func_call},
|
|
{"bitor", compile_special_binary_func_call},
|
|
{"bitxor", compile_special_binary_func_call},
|
|
|
|
{"string", compile_special_unary_func_call},
|
|
{"int", compile_special_unary_func_call},
|
|
{"float", compile_special_unary_func_call},
|
|
{"intern", compile_special_unary_func_call},
|
|
{"type-of", compile_special_unary_func_call},
|
|
{"get-function", compile_special_unary_func_call},
|
|
{"get-value", compile_special_unary_func_call},
|
|
{"functionp", compile_special_unary_func_call},
|
|
{"boundp", compile_special_unary_func_call},
|
|
{"not", compile_special_unary_func_call},
|
|
{"car", compile_special_unary_func_call},
|
|
{"cdr", compile_special_unary_func_call},
|
|
{"recip", compile_special_unary_func_call},
|
|
{"sqrt", compile_special_unary_func_call},
|
|
{"ln", compile_special_unary_func_call},
|
|
{"exp", compile_special_unary_func_call},
|
|
{"sin", compile_special_unary_func_call},
|
|
{"cos", compile_special_unary_func_call},
|
|
{"tan", compile_special_unary_func_call},
|
|
{"asin", compile_special_unary_func_call},
|
|
{"acos", compile_special_unary_func_call},
|
|
{"atan", compile_special_unary_func_call},
|
|
{"bigneg", compile_special_unary_func_call},
|
|
{"lsh", compile_special_unary_func_call},
|
|
{"ash", compile_special_unary_func_call},
|
|
};
|
|
const size_t N_NATIVE_FUNCTIONS = sizeof(NATIVE_FUNCTIONS) /
|
|
sizeof(NATIVE_FUNCTIONS[0]);
|
|
|
|
static ssize_t compile_string_node(CompileEnvironment *env, AstStringNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
return emit_instruction(err, stream, INST_STRING, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_BYTES, form->length, form->value) ? 1 : -1;
|
|
}
|
|
|
|
static ssize_t compile_int_node(CompileEnvironment *env, AstIntNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
|
|
return emit_instruction(err, stream, INST_INT, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_U64, form->value) ? 1 : -1;
|
|
}
|
|
|
|
static ssize_t compile_float_node(CompileEnvironment *env, AstFloatNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
|
|
return emit_instruction(err, stream, INST_FLOAT, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_DOUBLE, form->value) ? 1 : -1;
|
|
}
|
|
|
|
static ssize_t compile_null_node(CompileEnvironment *env, AstNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
return emit_instruction(err, stream, INST_NIL, 1,
|
|
ARG_REG, target->type, target->which) ? 1 : -1;
|
|
}
|
|
|
|
static ssize_t compile_quoted_symbol_node(CompileEnvironment *env, AstSymbolNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
return emit_instruction(err, stream, INST_INTERN_LIT, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_BYTES, form->name_length, form->name) ? 1 : -1;
|
|
}
|
|
|
|
static ssize_t compile_symbol_node(CompileEnvironment *env, AstSymbolNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
if (strcmp(form->name, "t") == 0) {
|
|
return emit_instruction(err, stream, INST_T, 1,
|
|
ARG_REG, target->type, target->which) ? 1 : -1;
|
|
} else if (form->is_property) {
|
|
return compile_quoted_symbol_node(env, form, target, stream, err);
|
|
}
|
|
LispReg *var_reg = lookup_local_var(env, form->name);
|
|
if (var_reg) {
|
|
if (SAME_REG(var_reg, target)) {
|
|
return 0;
|
|
}
|
|
// if the target is not an arg register, we can just set the target to
|
|
// the register that the variable is already in
|
|
if (target->type != REG_ARG) {
|
|
*target = *var_reg;
|
|
return 0;
|
|
}
|
|
return emit_instruction(err, stream, INST_MOV, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, var_reg->type, var_reg->which) ? 1 : -1;
|
|
} else {
|
|
// global variable
|
|
if (!lookup_variable(env, form)) {
|
|
// TODO add to queue to check later
|
|
}
|
|
LispReg sym_reg;
|
|
ssize_t ec = intern_and_save(env, stream, form->name, form->name_length,
|
|
&sym_reg, err);
|
|
if (ec < 0) {
|
|
return -1;
|
|
}
|
|
emit_instruction(err, stream, INST_GET_VALUE, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, sym_reg.type, sym_reg.which);
|
|
return ec + 1;
|
|
}
|
|
}
|
|
|
|
static ssize_t compile_quoted_quote_node(CompileEnvironment *env, AstQuoteNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
// return (quote internal-form)
|
|
LispReg arg_reg = {
|
|
.type = REG_ARG,
|
|
.which = 1,
|
|
};
|
|
ssize_t ec = byte_compile_form_internal(env, (AstNode *) form->form,
|
|
&arg_reg, stream, err);
|
|
if (ec < 0) {
|
|
return -1;
|
|
}
|
|
LispReg quote_sym_reg;
|
|
const char *name;
|
|
size_t name_len;
|
|
switch (form->type) {
|
|
case AST_QUOTE_COMMA:
|
|
name = "bq-comma";
|
|
name_len = sizeof("bq-comma") - 1;
|
|
break;
|
|
case AST_QUOTE_SPLICE:
|
|
name = "bq-splice";
|
|
name_len = sizeof("bq-splice") - 1;
|
|
break;
|
|
case AST_QUOTE_NORM:
|
|
name = "quote";
|
|
name_len = sizeof("quote") - 1;
|
|
break;
|
|
case AST_QUOTE_BACK:
|
|
name = "backquote";
|
|
name_len = sizeof("backquote") - 1;
|
|
break;
|
|
case AST_QUOTE_NONE:
|
|
// shouldn't happen
|
|
return 0;
|
|
}
|
|
ssize_t ec2 = intern_and_save(env, stream, name, name_len,
|
|
"e_sym_reg, err);
|
|
if (ec2 < 0) {
|
|
return -1;
|
|
}
|
|
if (!emit_instruction(err, stream, INST_MOV, 2,
|
|
ARG_REG, REG_ARG, (uint32_t) 0,
|
|
ARG_REG, quote_sym_reg.type, quote_sym_reg.which)) {
|
|
return -1;
|
|
}
|
|
if (!emit_instruction(err, stream, INST_LIST, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_U64, (uint64_t) 2)) {
|
|
return -1;
|
|
}
|
|
return ec + ec2 + 2;
|
|
}
|
|
|
|
static ssize_t compile_quote_node(CompileEnvironment *env, AstQuoteNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
switch (form->type) {
|
|
case AST_QUOTE_NORM:
|
|
case AST_QUOTE_BACK: {
|
|
env->quote = form->type;
|
|
size_t ec = byte_compile_form_internal(env, form->form, target,
|
|
stream, err);
|
|
env->quote = AST_QUOTE_NONE;
|
|
return ec;
|
|
}
|
|
case AST_QUOTE_COMMA:
|
|
case AST_QUOTE_SPLICE:
|
|
push_error_at_ast(err, (AstNode *) form, COMPILE_ERROR,
|
|
"comma or splice not inside a backquote");
|
|
return -1;
|
|
case AST_QUOTE_NONE:
|
|
// shouldn't happen, do nothing
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
static ssize_t compile_quoted_list_node(CompileEnvironment *env, AstListNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
LispReg arg_reg = {
|
|
.type = REG_ARG,
|
|
};
|
|
size_t total_emitted = 0;
|
|
for (size_t i = 0; i < form->nchildren; ++i) {
|
|
arg_reg.which = i;
|
|
ssize_t ec = byte_compile_form_internal(env, form->children[i],
|
|
&arg_reg, stream, err);
|
|
if (ec < 0) {
|
|
return -1;
|
|
}
|
|
total_emitted += ec;
|
|
}
|
|
if (!emit_instruction(err, stream, INST_LIST, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_U64, form->nchildren)) {
|
|
return -1;
|
|
}
|
|
return total_emitted + 1;
|
|
}
|
|
|
|
static ssize_t compile_backquote_quote_node(CompileEnvironment *env,
|
|
AstQuoteNode *form, LispReg *target,
|
|
FILE *stream, CompileError **err) {
|
|
if (form->type == AST_QUOTE_COMMA) {
|
|
env->quote = AST_QUOTE_NONE;
|
|
ssize_t ec = byte_compile_form_internal(env, form->form, target,
|
|
stream, err);
|
|
env->quote = AST_QUOTE_BACK;
|
|
return ec;
|
|
} else if (form->type == AST_QUOTE_SPLICE) {
|
|
// TODO handle this
|
|
return 0;
|
|
}
|
|
return compile_quoted_quote_node(env, form, target, stream, err);
|
|
}
|
|
|
|
static ssize_t compile_vector_node(CompileEnvironment *env, AstVectorNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
env->quote = AST_QUOTE_NORM;
|
|
LispReg arg_reg = {
|
|
.type = REG_ARG,
|
|
};
|
|
size_t total_emitted = 0;
|
|
for (size_t i = 0; i < form->nchildren; ++i) {
|
|
arg_reg.which = i;
|
|
ssize_t ec = byte_compile_form_internal(env, form->children[i],
|
|
&arg_reg, stream, err);
|
|
if (ec < 0) {
|
|
return -1;
|
|
}
|
|
total_emitted += ec;
|
|
}
|
|
if (!emit_instruction(err, stream, INST_VECTOR, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_U64, form->nchildren)) {
|
|
return -1;
|
|
}
|
|
env->quote = AST_QUOTE_NONE;
|
|
return total_emitted + 1;
|
|
}
|
|
|
|
static ssize_t compile_atom_node(CompileEnvironment *env, AstNode *form,
|
|
LispReg *target, FILE *stream,
|
|
CompileError **err) {
|
|
switch (form->type) {
|
|
case AST_TYPE_INT:
|
|
return compile_int_node(env, (AstIntNode *) form, target, stream, err);
|
|
case AST_TYPE_FLOAT:
|
|
return compile_float_node(env, (AstFloatNode *)form, target, stream, err);
|
|
case AST_TYPE_STRING:
|
|
return compile_string_node(env, (AstStringNode *) form, target, stream, err);
|
|
case AST_TYPE_NULL:
|
|
return compile_null_node(env, form, target, stream, err);
|
|
case AST_TYPE_SYMBOL:
|
|
if (env->quote == AST_QUOTE_NONE) {
|
|
return compile_symbol_node(env, (AstSymbolNode *) form, target,
|
|
stream, err);
|
|
} else {
|
|
return compile_quoted_symbol_node(env, (AstSymbolNode *) form,
|
|
target, stream, err);
|
|
}
|
|
case AST_TYPE_QUOTE:
|
|
if (env->quote == AST_QUOTE_NONE) {
|
|
return compile_quote_node(env, (AstQuoteNode *) form, target, stream, err);
|
|
} else if (env->quote == AST_QUOTE_BACK) {
|
|
return compile_backquote_quote_node(env, (AstQuoteNode *) form,
|
|
target, stream,err);
|
|
} else {
|
|
return compile_quoted_quote_node(env, (AstQuoteNode *) form, target,
|
|
stream, err);
|
|
}
|
|
case AST_TYPE_VECTOR:
|
|
return compile_vector_node(env, (AstVectorNode *)form, target,
|
|
stream, err);
|
|
case AST_TYPE_LIST:
|
|
if (env->quote == AST_QUOTE_NONE) {
|
|
return compile_quoted_list_node(env, (AstListNode *) form, target,
|
|
stream, err);
|
|
} else {
|
|
// probably an error, don't do anything though
|
|
return 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
static AstListNode *make_list_func_node(AstNode **nodes, size_t count) {
|
|
AstListNode *node = malloc(sizeof(AstListNode));
|
|
node->parent.type = AST_TYPE_LIST;
|
|
node->parent.line = 0;
|
|
node->parent.col = 0;
|
|
node->nchildren = count + 1;
|
|
node->children = malloc(sizeof(AstNode *) * (count + 1));
|
|
node->children[0] = malloc(sizeof(AstSymbolNode));
|
|
node->children[0]->type = AST_TYPE_SYMBOL;
|
|
node->children[0]->line = 0;
|
|
node->children[0]->col = 0;
|
|
((AstSymbolNode *) node->children[0])->is_property = false;
|
|
((AstSymbolNode *) node->children[0])->name = "list";
|
|
((AstSymbolNode *) node->children[0])->name_length = sizeof("list") - 1;
|
|
((AstSymbolNode *) node->children[0])->skip_free = true;
|
|
memcpy(node->children + 1, nodes, count * sizeof(AstNode *));
|
|
return node;
|
|
}
|
|
|
|
static ssize_t compile_generic_function_call(CompileEnvironment *env,
|
|
AstListNode *form,
|
|
LispReg *target,
|
|
FILE *stream,
|
|
CompileError **err) {
|
|
size_t emitted_count = 0;
|
|
AstSymbolNode *name = (AstSymbolNode *) form->children[0];
|
|
FunctionEntry *entry = lookup_function(env, name);
|
|
if (!entry) {
|
|
push_error_at_ast(err, (AstNode *) form, COMPILE_ERROR,
|
|
"unknown function");
|
|
} else if (!function_arguments_ok(form, entry, err)) {
|
|
// arguments invalid, give up compiling form
|
|
return -1;
|
|
}
|
|
ssize_t ec = 0;
|
|
ec += emit_generic_arg_list(env, form->children + 1, form->nchildren - 1,
|
|
false, stream, err);
|
|
LispReg name_reg;
|
|
ec += intern_and_save(env, stream, name->name, name->name_length,
|
|
&name_reg, err);
|
|
if (ec == -1) {
|
|
return -1;
|
|
}
|
|
ec += emit_instruction(err, stream, INST_FUNCALL, 2,
|
|
ARG_REG, name_reg.type, name_reg.which,
|
|
ARG_U64, form->nchildren - 1);
|
|
if (target && target->type != REG_VAL) {
|
|
ec += emit_instruction(err, stream, INST_MOV, 2,
|
|
ARG_REG, target->type, target->which,
|
|
ARG_REG, REG_RET, (uint32_t) 0);
|
|
} else if (target) {
|
|
target->type = REG_RET;
|
|
target->which = 0;
|
|
}
|
|
return ec;
|
|
}
|
|
|
|
static ssize_t byte_compile_form_internal(CompileEnvironment *env,
|
|
AstNode *form, LispReg *target,
|
|
FILE *stream, CompileError **err) {
|
|
ssize_t extra_ins = 0;
|
|
// if target is one of the arg registers and it contains a local variable,
|
|
// we want to save it to a saved register
|
|
if (target && target->type == REG_ARG) {
|
|
extra_ins = maybe_save_argument_reg(env, target, stream, err);
|
|
if (extra_ins < 0) {
|
|
return -1;
|
|
}
|
|
}
|
|
if (form->type != AST_TYPE_LIST) {
|
|
if (!target && (form->type != AST_TYPE_QUOTE ||
|
|
((AstQuoteNode *) form)->type == AST_TYPE_QUOTE)) {
|
|
// no use in compiling a literal if the value will just be thrown out
|
|
return 0;
|
|
}
|
|
return extra_ins + compile_atom_node(env, form, target, stream, err);
|
|
} else if (env->quote != AST_QUOTE_NONE) {
|
|
if (!target) {
|
|
return 0;
|
|
}
|
|
return extra_ins + compile_quoted_list_node(env, (AstListNode *) form, target,
|
|
stream, err);
|
|
} else if (is_function_call(form)) {
|
|
for (size_t i = 0; i < N_NATIVE_FUNCTIONS; ++i) {
|
|
if (is_function_call_named(NATIVE_FUNCTIONS[i].name, form)) {
|
|
return extra_ins + NATIVE_FUNCTIONS[i].handler(env,
|
|
(AstListNode *) form,
|
|
target, stream, err);
|
|
}
|
|
}
|
|
return extra_ins + compile_generic_function_call(env,
|
|
(AstListNode *) form,
|
|
target,
|
|
stream, err);
|
|
}
|
|
return extra_ins;
|
|
}
|
|
|
|
ssize_t byte_compile_form(CompileEnvironment *env, AstNode *form, FILE *stream,
|
|
CompileError **err) {
|
|
env->first_available_val = 0;
|
|
env->quote = AST_QUOTE_NONE;
|
|
size_t ninst = byte_compile_form_internal(env, form, NULL, stream, err);
|
|
if (COMPILE_FORMAT == COMPILE_FORMAT_ASM) {
|
|
fputc('\n', stream);
|
|
}
|
|
// reverse err
|
|
if (err) {
|
|
CompileError *cur_err = *err;
|
|
CompileError *prev_err = NULL;
|
|
while (cur_err) {
|
|
CompileError *next = cur_err->next;
|
|
cur_err->next = prev_err;
|
|
prev_err = cur_err;
|
|
cur_err = next;
|
|
}
|
|
*err = prev_err;
|
|
}
|
|
return ninst;
|
|
}
|
|
|
|
void load_toplevel_definition(CompileEnvironment *env, AstNode *form,
|
|
CompileError **err) {
|
|
if (is_function_call_named("defun", form)) {
|
|
parse_and_add_function(env, (AstListNode *) form, err);
|
|
}
|
|
}
|