blob: 331193d11109d60a5471d6cc22c8e66a5626d3d4 [file] [log] [blame]
/* -*- mode:c -*- */
#include "compiler.h"
#include "gc.h"
#include "lib/std.h"
#include "lisp.h"
#include "plat/plat.h"
#include <dasm_proto.h>
#include <dasm_x86.h>
#include <libgen.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#define value_size sizeof(value_t)
|.arch x86;
|.macro setup, nvars;
|1:;
| push ebp;
| mov ebp, esp;
| sub esp, (value_size * nvars);
|.endmacro;
|.macro cleanup;
| mov esp, ebp;
| pop ebp;
| ret;
|.endmacro;
|.macro call_extern, address;
| call &address;
|.endmacro;
dasm_State *d;
unsigned int npc = 8;
|.macro run_gc;
| mov eax, esp;
| push ebp;
| push eax;
| mov eax, _do_gc;
| call eax;
|.endmacro;
struct function *find_function(struct environment *env, char *name)
{
struct function *f;
for (f = env->first; f && strcmp(f->name, name); f = f->prev)
{
}
return f;
}
unsigned int local_alloc(struct local *local)
{
for (int i = 0; i < local->num_stack_slots; i++)
{
if (local->stack_slots[i] == false)
{
local->stack_slots[i] = true;
if (i >= local->num_stack_entries)
local->num_stack_entries++;
return i;
}
}
int old_size = local->num_stack_slots;
local->num_stack_slots += 4;
local->stack_slots =
realloc(local->stack_slots, local->num_stack_slots * sizeof(bool));
// unreadable: set the remaining slots to unused
memset(local->stack_slots + old_size, 0, local->num_stack_slots - old_size);
local->stack_slots[old_size] = true;
return old_size;
}
void local_free(struct local *local, unsigned int slot)
{
local->stack_slots[slot] = false;
}
void del_local(struct local *local)
{
free(local->stack_slots);
for (struct variable *next, *f = local->first; f; f = next)
{
next = f->prev;
free(f);
}
}
void del_env(struct environment *env)
{
for (struct function *next, *f = env->first; f; f = next)
{
next = f->prev;
// We're not gonna bother munmap()ing the function
if (f->args)
free(f->args);
free(f);
}
for (struct loaded_file *next, *l = env->first_loaded; l; l = next)
{
next = l->previous;
free(l->resolved_path);
free(l);
}
free(env);
}
void add_load(struct environment *env, char *path)
{
static char buffer[512];
long size = readlink(path, buffer, 512);
buffer[size] = '\0';
char *resolved = strdup(buffer);
struct loaded_file *f = malloc(sizeof(struct loaded_file));
f->resolved_path = resolved;
f->previous = env->first_loaded;
env->first_loaded = f;
}
struct error compile_function(value_t args, enum namespace namespace,
struct environment *env,
struct local *local_out,
struct local *local_parent,
struct args **args_out, char *name,
char *path,
dasm_State **state)
{
UNUSED(namespace);
E_INIT();
dasm_State *d;
dasm_State **Dst = &d;
|.section code, imports;
dasm_init(&d, DASM_MAXSECTION);
|.globals lbl_;
void *labels[lbl__MAX];
dasm_setupglobal(&d, labels, lbl__MAX);
|.actionlist lisp_actions;
dasm_setup(&d, lisp_actions);
struct local local;
local.parent = NULL;
local.first = NULL;
local.num_vars = 0;
local.npc = 8;
local.nextpc = 0;
local.stack_slots = malloc(sizeof(bool) * 4);
memset(local.stack_slots, 0, sizeof(bool) * 4);
local.num_stack_slots = 4;
local.num_stack_entries = 0;
local.num_closure_slots = 0;
local.parent = local_parent;
local.current_function_name = name;
local.current_file_path = path;
dasm_growpc(&d, local.npc);
value_t arglist = car(args);
value_t body = cdr(args);
// This will add the arguments to local too.
struct args *ar;
TRY(list_to_args(env, arglist, &local, &ar));
local.args = ar;
if (!ar)
{
NEARVAL(arglist);
THROW(EMALFORMED, "Malformed argument list");
}
for (value_t body_ = body; !nilp(body_); body_ = cdr(body_))
{
TRY(walk_and_alloc(env, &local, carref(body_), false));
}
| setup (local.num_stack_entries);
memset(local.stack_slots, 0, local.num_stack_slots * sizeof(bool));
local.num_stack_entries = 0;
for (; !nilp(body); body = cdr(body))
{
bool tail = nilp(cdr(body));
TRY(compile_expression(env, &local, car(body), tail, Dst));
}
| cleanup;
if (local_out)
*local_out = local;
else
del_local(&local);
if (args_out)
*args_out = ar;
if (!local_out && !args_out)
free(ar);
*state = d;
OKAY();
}
struct error compile_tl(value_t val, struct environment *env, char *fname)
{
E_INIT();
NEARVAL(val);
if (!listp(val))
{
THROW(EEXPECTED, "Top level form must be a list");
}
value_t form = car(val);
value_t args = cdr(val);
if (symstreq(form, "defun") || symstreq(form, "defmacro"))
{
enum namespace namespace = NS_FUNCTION;
if (symstreq(form, "defmacro"))
namespace = NS_MACRO;
struct local local;
struct args *a;
char *name = (char *)(car(args) ^ SYMBOL_TAG);
dasm_State *d;
TRY(compile_function(cdr(args), namespace, env, &local,
NULL, &a, name, fname, &d));
add_function(env, name, link_program(&d), a, namespace);
dasm_free(&d);
del_local(&local);
}
else if (symstreq(form, "progn"))
{
for (value_t val = args; !nilp(val); val = cdr(val))
{
TRY(compile_tl(car(val), env, fname));
}
}
else if (symstreq(form, "load"))
{
if (length(args) != 1)
{
NEARVAL(args);
THROW(EARGS, "load expects exactly 1 argument, %d given",
length(args));
}
load_relative(env, fname, car(args));
}
OKAY();
}
struct error walk_and_alloc(struct environment *env, struct local *local, value_t *bp, bool quoted)
{
// Note: this kind of sucks. Some of the quote-handling code is
// duplicated here and compile_expression. TODO: refactor
// eventually.
E_INIT();
value_t body = *bp;
if (!listp(body))
OKAY();
value_t args = cdr(body);
if (!quoted && symstreq(car(body), "let1"))
{
int slot = local_alloc(local);
value_t expr = cdr(args);
for (; !nilp(expr); expr = cdr(expr))
{
walk_and_alloc(env, local, carref(expr), false);
}
local_free(local, slot);
}
else if (!quoted && symstreq(car(body), "lambda"))
{
// We don't want to walk the lambda because it's another function. When
// the lambda is compiled it will be walked.
OKAY();
}
else
{
if (quoted)
{
if (symstreq(car(body), "unquote") || symstreq(car(body), "unquote-splice"))
{
for (value_t b = cdr(body); !nilp(b); b = cdr(b))
{
walk_and_alloc(env, local, carref(b), false);
}
}
}
else
{
// Is this a macro?
struct function *mac = NULL;
if (symbolp(car(body)))
mac = find_function(env, (char *)(car(body) ^ SYMBOL_TAG));
else if (consp(car(body))) // consp, not just listp, since we don't care about nil.
walk_and_alloc(env, local, carref(body), false);
if (mac && mac->namespace == NS_MACRO)
{
unsigned char pool = push_pool(0);
value_t form = call_list(mac, args);
pop_pool(pool);
add_to_pool(form);
*bp = form;
walk_and_alloc(env, local, bp, false);
}
else
{
bool should_quote = symstreq(car(body), "quote") || symstreq(car(body), "backquote");
for (; !nilp(args); args = cdr(args))
{
walk_and_alloc(env, local, carref(args), should_quote);
}
}
}
}
OKAY();
}
bool load(struct environment *env, char *path)
{
if (!file_exists(path))
return false;
add_load(env, path);
unsigned char pool = make_pool();
unsigned char pop = push_pool(pool);
struct istream *is = new_fistream(path, false);
if (!is)
return false;
value_t val;
struct error compile_error, read_error;
while (IS_OKAY((read_error = read1(is, &val))))
{
if (!IS_OKAY((compile_error = compile_tl(val, env, path))))
{
ereport(compile_error);
goto failure;
}
}
if (!read_error.safe_state)
{
goto failure;
}
del_fistream(is);
pop_pool(pop);
return true;
failure:
del_fistream(is);
pop_pool(pool);
return false;
}
value_t load_relative(struct environment *env, char *to, value_t name)
{
if (!stringp(name))
return nil;
char *new_path = (char *)(name ^ STRING_TAG);
char *relative_to = strdup(to);
char full_path[512];
snprintf(full_path, 512, "%s/%s", dirname(relative_to), new_path);
free(relative_to);
if (load(env, full_path))
return t;
else
return nil;
}
struct error compile_file(char *filename, struct environment **e)
{
E_INIT();
value_t val;
struct environment *env = malloc(sizeof(struct environment));
env->first = NULL;
env->first_loaded = NULL;
add_load(env, filename);
TRY(load_std(env));
bool ok_ = load(env, filename);
if (!ok_)
{
free(env);
NEARFL(filename, 1);
THROWSAFE(ENOTFOUND);
}
*e = env;
OKAY();
}
int nextpc(struct local *local, dasm_State **Dst)
{
int n = local->nextpc++;
if (n > local->npc)
{
local->npc += 16;
dasm_growpc(Dst, local->npc);
}
return n;
}
struct error compile_backquote(struct environment *env, struct local *local,
value_t val, dasm_State **Dst)
{
E_INIT();
if (!listp(val))
{
| mov eax, (val);
}
else
{
value_t fsym = car(val), args = cdr(val);
int nargs = length(args),
n = length(val);
NEARVAL(val);
if (symstreq(fsym, "unquote"))
{
if (nargs != 1)
{
THROW(EARGS, "unquote (or ,) takes exactly 1 argument");
}
TRY(compile_expression(env, local, car(args), false, Dst));
}
else
{
// tail of the list
| push nil;
for (int i = n - 1; i >= 0; i--)
{
value_t v = elt(val, i);
if (listp(v) && symstreq(car(v), "unquote-splice"))
{
NEARVAL(v);
if (length(v) != 2)
{
THROW(EARGS, "unquote-splice (or ,@) takes exactly 1 argument");
}
value_t expr = car(cdr(v));
TRY(compile_expression(env, local, expr, false, Dst));
| push eax;
| call_extern merge2;
| add esp, 8;
| push eax;
}
else
{
TRY(compile_backquote(env, local, v, Dst));
| push eax;
| call_extern cons;
| add esp, 8;
// Remove unnecessary pop
| push eax;
}
}
| pop eax;
}
}
OKAY();
}
value_t eval(struct environment *env, value_t form)
{
gc_push_segment(&form, 1);
// Eval!
value_t function = cons(nil, cons(form, nil));
gc_set_retained(0, function);
struct local local;
struct args *args;
dasm_State *d;
struct error err;
if (!IS_OKAY((err = compile_function(function, NS_ANONYMOUS, env, &local, NULL,
&args, "", "/", &d))))
{
ereport(err);
return nil;
}
del_local(&local);
value_t (*f)() = link_program(&d);
dasm_free(&d);
free(args);
gc_prepare_call(0);
value_t val = f();
gc_pop_segment();
return val;
}
struct error compile_variable(struct variable *v, dasm_State *Dst)
{
E_INIT();
switch (v->type)
{
case V_ARGUMENT:
| mov eax, dword[ebp + (value_size * (v->number + 2))];
break;
case V_BOUND:
| mov eax, dword[ebp - ((v->number + 1) * value_size)];
break;
case V_FREE:
// edi is the closure context pointer
| mov eax, dword[edi + (v->number * value_size)];
break;
default:
THROW(EUNIMPL, "Sorry, can only access V_ARGUMENT, V_BOUND, and V_FREE vars");
}
OKAY();
}
struct error compile_expression(struct environment *env, struct local *local,
value_t val, bool tail, dasm_State **Dst)
{
E_INIT();
NEARVAL(val);
if (symstreq(val, "nil") || nilp(val))
{
| mov eax, (nil);
}
else if (symstreq(val, "t"))
{
| mov eax, (t);
}
else if (integerp(val) || stringp(val))
{
| mov eax, val;
}
else if (listp(val))
{
value_t fsym = car(val);
value_t args = cdr(val);
int nargs = length(args);
if (!symbolp(fsym))
{
THROW(EEXPECTED, "Function name must be a symbol");
}
if (symstreq(fsym, "if"))
{
if (nargs < 2 || nargs > 3)
{
THROW(EARGS, "Must give at least 2 arguments to if");
}
TRY(compile_expression(env, local, car(args), false, Dst));
int false_label = nextpc(local, Dst),
after_label = nextpc(local, Dst);
// result is in eax
| cmp eax, (nil);
| je =>false_label;
TRY(compile_expression(env, local, elt(args, 1), tail, Dst));
| jmp =>after_label;
|=>false_label:;
if (nargs == 3)
TRY(compile_expression(env, local, elt(args, 2), tail, Dst));
|=>after_label:;
}
else if (symstreq(fsym, "and") || symstreq(fsym, "or"))
{
bool or = symstreq(fsym, "or"); // false == and
// Boolean and and or, short circuit like &&/||
if (nargs < 1)
{
THROW(EARGS, "and & or require at least 1 argument.");
}
int after = nextpc(local, Dst);
for (; !nilp(args); args = cdr(args))
{
NEARVAL(args);
TRY(compile_expression(env, local, car(args), false, Dst));
if (!nilp(cdr(args)))
{
| cmp eax, nil;
if (or)
{
| jne =>after;
}
else
{
| je =>after;
}
}
}
|=>after:;
}
else if (symstreq(fsym, "progn"))
{
for (value_t val = args; !nilp(val); val = cdr(val))
{
NEARVAL(args);
bool t = tail && nilp(cdr(val));
TRY(compile_expression(env, local, car(val), t, Dst));
}
}
else if (symstreq(fsym, "let1"))
{
if (nargs < 2)
{
THROW(EARGS, "Must give at least 2 arguments to let1");
}
value_t binding = car(args);
value_t rest = cdr(args);
NEARVAL(binding);
if (length(binding) != 2)
{
printval(args, 0);
THROW(EARGS, "Binding list in let1 must contain exactly two entries");
}
NEARVAL(rest);
value_t name = car(binding);
value_t value = car(cdr(binding));
TRY(compile_expression(env, local, value, false, Dst));
int i = local_alloc(local);
add_variable(local, V_BOUND, (char *)(name ^ SYMBOL_TAG), i);
| mov dword[ebp - ((i + 1) * value_size)], eax;
for (; !nilp(rest); rest = cdr(rest))
{
bool t = tail && nilp(cdr(rest));
NEARVAL(rest);
TRY(compile_expression(env, local, car(rest), t, Dst));
}
local_free(local, i);
}
else if (symstreq(fsym, "gc"))
{
if (nargs)
{
THROW(EARGS, "gc takes no arguments");
}
| run_gc;
}
else if (symstreq(fsym, "quote"))
{
if (nargs != 1)
THROW(EARGS, "quote should take exactly 1 argument");
// Simple!
| mov eax, (car(args));
}
else if (symstreq(fsym, "backquote"))
{
if (nargs != 1)
THROW(EARGS, "backquote should take exactly 1 argument");
TRY(compile_backquote(env, local, car(args), Dst));
}
else if (symstreq(fsym, "function"))
{
if (nargs != 1)
{
THROW(EARGS, "function should take exactly 1 argument");
}
NEARVAL(args);
if (!symbolp(car(args)))
{
THROW(EINVALID, "argument to function should be a symbol resolvable at "
"compile time");
}
char *name = (char *)(car(args) ^ SYMBOL_TAG);
if (!strcmp(name, local->current_function_name))
{
| push 0;
| push local->args;
| push <1;
| call_extern create_closure;
}
else
{
struct function *f = find_function(env, name);
if (!f)
{
THROW(EINVALID, "Function `%s' does not exist", (char *)(car(args) ^ SYMBOL_TAG));
}
value_t closure = create_closure(f->code_ptr, f->args, 0);
| mov eax, (closure);
}
}
else if (symstreq(fsym, "list"))
{
| push (nil);
for (int i = nargs - 1; i >= 0; i--)
{
TRY(compile_expression(env, local, elt(args, i), false, Dst));
| push eax;
| call_extern cons;
| add esp, (2 * value_size);
| push eax;
}
| pop eax;
}
else if (symstreq(fsym, "lambda"))
{
// Compile the function with this as the parent scope
struct local new_local;
struct args *nargs_out;
dasm_State *d;
TRY(compile_function(
args, NS_ANONYMOUS, env, &new_local, local, &nargs_out,
"recurse", local->current_file_path, &d));
// Link the function
void *func_ptr = link_program(&d);
// Create a closure object with the correct number of captures at
// runtime
| push (new_local.num_closure_slots);
| push (nargs_out);
| push (func_ptr);
| call_extern create_closure;
| add esp, 12;
// Walk the generated local scope for V_FREE variables, since each
// of these exists in our scope (or higher), evaluate it and set it
// as a member of the lambda capture.
for (struct variable *var = new_local.first; var; var = var->prev)
{
if (var->type == V_FREE)
{
// Closure in eax
| push eax;
// Variable now in eax
TRY(compile_variable(find_variable(local, var->name), Dst));
| push eax;
// The capture offset
| push (var->number);
| call_extern set_closure_capture_variable;
// Skip the value and index
| add esp, 8;
// Pop the closure back in to eax
| pop eax;
}
}
// Closure is still in eax
dasm_free(&d);
del_local(&new_local);
}
else if (symstreq(fsym, "eval"))
{
if (nargs != 1)
{
THROW(EARGS, "eval takes exactly 1 argument");
}
TRY(compile_expression(env, local, car(args), false, Dst));
| push eax;
| push (env);
| call_extern eval;
}
else if (symstreq(fsym, "load"))
{
if (nargs != 1)
{
THROW(EARGS, "load takes exactly 1 argument, %d given", nargs);
}
TRY(compile_expression(env, local, car(args), false, Dst));
| push eax;
| push (local->current_file_path);
| push (env);
| call_extern load_relative;
}
else
{
char *name = (char *)(fsym ^ SYMBOL_TAG);
struct function *func = find_function(env, name);
bool is_recursive = false;
struct args *nargs_needed = NULL;
// The number of arguments actually passed on the stack,
// i.e. all varargs are 1.
int real_nargs;
if (local->current_function_name &&
symstreq(fsym, local->current_function_name))
{
is_recursive = true;
nargs_needed = local->args;
}
else
{
if (func == NULL)
{
THROW(EINVALID, "Function %s undefined", name);
}
nargs_needed = func->args;
}
if (!are_args_acceptable(nargs_needed, nargs))
{
THROW(EARGS,
"wrong number of args in function call: %s, "
"want %d args but given %d\n",
name, nargs_needed->num_required, nargs);
}
int total_taken = nargs_needed->num_optional +
nargs_needed->num_required;
real_nargs = total_taken + (nargs_needed->variadic ? 1 : 0);
if (is_recursive || func->namespace == NS_FUNCTION)
{
int nargs = length(args);
int line = cons_line(val);
char *file = cons_file(val);
if (nargs_needed->variadic)
{
| push (nil);
}
if (nargs > total_taken && nargs_needed->variadic)
{
// We are passing varargs, which means we need to make a list
for (int i = nargs - 1; i >= total_taken; i--)
{
TRY(compile_expression(env, local, elt(args, i), false, Dst));
| push eax;
| call_extern cons;
| add esp, 8;
| push eax;
}
}
for (int i = nargs_needed->num_optional - 1;
i >= nargs - nargs_needed->num_required; i--)
{
// Push the default optional values
| push (nargs_needed->optional_arguments[i].value);
}
int min = MIN(nargs, total_taken);
for (int i = min - 1; i >= 0; i--)
{
TRY(compile_expression(env, local, elt(args, i), false, Dst));
| push eax;
}
if (is_recursive)
{
if (tail)
{
// Move all the arguments pushed to the stack
// back up to the argument bit of the stack.
for (int i = 0; i < real_nargs; i++)
{
| pop eax;
| mov dword[ebp + (value_size * (i + 2))], eax;
}
// Jmp back to start
| mov esp, ebp;
| pop ebp;
| jmp <1;
}
else
{
| call <1;
}
}
else
{
// | mov ebx, (func->code_addr);
| call_extern func->code_addr;
}
| add esp, (real_nargs * value_size);
// result in eax
}
else if (func->namespace == NS_MACRO)
{
// Make sure that the stuff allocated by the macro isn't in a
// pool
unsigned char pool = push_pool(0);
value_t expanded_to = call_list(func, args);
pop_pool(pool);
TRY(compile_expression(env, local, expanded_to, false, Dst));
}
}
}
else if (symbolp(val))
{
if (symstreq(val, "+current-file+"))
{
value_t file_name_val = strval(local->current_file_path);
| mov eax, (file_name_val);
}
else if (symstreq(val, "+current-env+"))
{
// TODO: we return this as a raw "integer", which is a bad
// idea. Once classes are added this needs to be wrapped
// in a class.
| mov eax, (env);
}
else
{
struct variable *v =
find_variable(local, (char *)(val ^ SYMBOL_TAG));
if (!v)
{
THROW(EINVALID, "Variable `%s' unbound", (char *)(val ^ SYMBOL_TAG));
}
TRY(compile_variable(v, Dst));
}
}
else if (closurep(val))
{
| mov eax, val;
}
else
{
printval(val, 1);
THROW(EUNIMPL, "Don't know how to compile this, sorry.");
}
OKAY();
}
struct variable *add_variable(struct local *local, enum var_type type,
char *name, int number)
{
struct variable *var = malloc(sizeof(struct variable));
var->prev = local->first;
var->type = type;
var->name = name;
var->number = number;
local->first = var;
return var;
}
void destroy_local(struct local *local)
{
for (struct variable *v = local->first; v;)
{
struct variable *t = v;
v = v->prev;
free(t);
}
}
struct variable *find_variable(struct local *local, char *name)
{
struct variable *v = local->first;
for (; v && strcmp(v->name, name) != 0; v = v->prev)
{
}
if (!v)
{
if (local->parent)
{
v = find_variable(local->parent, name);
if (v)
{
// We found this in a parent scope, add it as a V_FREE variable
// to skip the search.
v = add_variable(local, V_FREE, name,
local->num_closure_slots++);
}
}
}
return v;
}
extern value_t _call_list(void *addr, value_t list, value_t *edi);
value_t call_list_args(void *code_ptr, struct args *args, value_t list,
void *data)
{
list = deep_copy(list);
int nargs = length(list);
value_t *val = &list;
for (value_t i = list; !nilp(i); i = cdr(i))
{
val = cdrref(i);
}
int total_required = args->num_required + args->num_optional;
if (nargs > total_required)
{
// Take the remainder of the list and put it as the last item in the
// list.
value_t trailing = cxdr(list, total_required);
value_t last_item = cons(trailing, nil);
*cxdrref(&list, total_required) = last_item;
}
else if (nargs < total_required)
{
for (int i = nargs - args->num_required; i < args->num_optional; i++)
{
// Append the i-th defualt argument
value_t appended = cons(args->optional_arguments[i].value, nil);
*val = appended;
val = cdrref(appended);
}
}
// We want to call this if we pass the correct # of arguments or less, just
// not if we have already passed varargs. Appends a nil argument.
if (nargs <= total_required)
{
// Enough real arguments but no variadic arguments. Pass a nil list.
*val = cons(nil, nil);
}
return _call_list(code_ptr, list, data);
}
value_t call_list(struct function *fun, value_t list)
{
return call_list_args(fun->code_ptr, fun->args, list, NULL);
}
value_t call_list_closure(struct closure *c, value_t list)
{
return call_list_args(c->function, c->args, list, c->data);
}
struct args *new_args()
{
struct args *a = malloc(sizeof(struct args));
a->num_optional = 0;
a->num_required = 0;
a->variadic = false;
return a;
}
struct args *add_optional_arg(struct args *args, value_t name, value_t value)
{
int i = args->num_optional++;
args =
realloc(args, sizeof(struct args) + sizeof(struct optional_argument) *
args->num_optional);
args->optional_arguments[i] = (struct optional_argument){
.value = value,
.name = name,
};
return args;
}
bool are_args_acceptable(struct args *args, int number)
{
if (args->variadic)
{
return number >= args->num_required;
}
else
{
return number >= args->num_required &&
number <= args->num_required + args->num_optional;
}
}
struct error list_to_args(struct environment *env, value_t list,
struct local *local, struct args **a)
{
E_INIT();
struct args *args = new_args();
bool in_optional = false;
for (value_t i = list; !nilp(i); i = cdr(i))
{
value_t val = car(i);
NEARVAL(i);
if (symbolp(val))
{
if (!args->variadic && symstreq(val, "&"))
{
i = cdr(i);
value_t name = car(i);
if (!symbolp(name))
{
THROW(EEXPECTED, "You must provide a symbol after & in an argument list "
"to bind the\n"
"variadic arguments to.");
}
args->variadic = true;
add_variable(local, V_ARGUMENT, (char *)(name ^ SYMBOL_TAG),
args->num_optional + args->num_required);
continue;
}
if (!in_optional)
{
add_variable(local, V_ARGUMENT, (char *)(val ^ SYMBOL_TAG),
args->num_required++);
}
else
{
char *name = (char *)(val ^ SYMBOL_TAG);
if (name[0] == '&')
{
THROW(EINVALID, "Non-optional argument following optional arguments "
"starts with a &\n"
"did you mean to declare a variadic argument? If so "
"leave a space\n"
"between the & and name.");
}
else
{
THROW(EINVALID, "Cannot define a non-optional argument after an "
"optional one.");
}
}
}
else if (listp(val))
{
NEARVAL(val);
in_optional = true;
int len = length(val);
if (len != 2)
{
THROW(EINVALID, "A list defining an optional value must be structured like "
"(name expr)\n"
"with exactly two arguments.");
}
value_t name = car(val);
value_t expr = car(cdr(val));
value_t function = cons(nil, cons(expr, nil));
dasm_State *d;
TRY(compile_function(function, NS_ANONYMOUS, env, NULL, NULL, NULL,
NULL, local->current_file_path, &d));
// TODO: GC stack top!
value_t (*compiled)() = link_program(&d);
value_t value = compiled();
args = add_optional_arg(args, name, value);
add_variable(local, V_ARGUMENT, (char *)(name ^ SYMBOL_TAG),
args->num_required + args->num_optional - 1);
dasm_free(&d);
}
}
*a = args;
OKAY();
}
void display_args(struct args *args)
{
printf("Args object taking %d require arguments and %d optionals:\n",
args->num_required, args->num_optional);
for (int i = 0; i < args->num_optional; i++)
{
printf(" %d\t%s\n", i,
(char *)(args->optional_arguments[i].name ^ SYMBOL_TAG));
printval(args->optional_arguments[i].value, 2);
}
}