blob: 6299e0354dbdf9560091e4acc4399d0037dd9e76 [file] [log] [blame]
#include "lisp.h"
#include "error.h"
#include "plat/plat.h"
#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
struct alloc *first_a = NULL, *last_a = NULL;
value_t nil = 0b00101111; // magic ;)
value_t t = 1 << 3;
unsigned char max_pool = 0, current_pool = 0;
value_t intval(int i)
{
i <<= 2;
i |= INT_TAG;
return i;
}
void add_this_alloc(struct alloc *a, int tag)
{
a->mark = -1;
a->type_tag = tag;
a->pool = current_pool;
if (last_a)
{
a->prev = last_a;
last_a->next = a;
a->next = NULL;
last_a = a;
}
else
{
a->prev = a->next = NULL;
first_a = last_a = a;
}
}
value_t cons(value_t car, value_t cdr)
{
struct cons_alloc *item = malloc_aligned(sizeof(struct cons_alloc));
struct cons *c = &item->cons;
c->car = car;
c->cdr = cdr;
c->line = 0;
c->name = NULL;
value_t v = (value_t)c;
v |= CONS_TAG;
add_this_alloc(&item->alloc, CONS_TAG);
return v;
}
void skipws(struct istream *is)
{
start:
while (isspace(is->peek(is)))
is->get(is);
if (is->peek(is) == ';')
{
while (is->get(is) != '\n')
{
}
// Only time I ever use labels is for stuff like this. Compiler would
// probably optimize this if I used recursion but I don't want to
// bother.
goto start;
}
}
bool isallowedchar(char c)
{
return (c >= '#' && c <= '\'') || (c >= '*' && c <= '/') ||
(c >= '<' && c <= '@');
}
bool issymstart(char c)
{
return isalpha(c) || isallowedchar(c);
}
bool issym(char c)
{
return isalpha(c) || isallowedchar(c) || isdigit(c);
}
struct error readsym(struct istream *is, value_t *val)
{
E_INIT();
skipws(is);
if (!issymstart(is->peek(is)))
THROWSAFE(EEXPECTED);
int size = 8;
struct alloc *a = malloc_aligned(size + sizeof(struct alloc));
char *s = (char *)(a + 1);
s[0] = is->get(is);
for (int i = 1;; i++)
{
if (i >= size)
{
size *= 2;
a = realloc_aligned(a, size + sizeof(struct alloc));
s = (char *)(a + 1);
}
if (issym(is->peek(is)))
{
s[i] = is->get(is);
}
else
{
s[i] = 0;
*val = (value_t)s;
*val |= SYMBOL_TAG;
add_this_alloc(a, SYMBOL_TAG);
OKAY();
}
}
}
struct error readstr(struct istream *is, value_t *val)
{
E_INIT();
skipws(is);
if (is->peek(is) != '"')
THROWSAFE(EEXPECTED);
bool escape = false;
int size = 8;
struct alloc *a = malloc_aligned(size + sizeof(struct alloc));
char *s = (char *)(a + 1);
(void)is->get(is);
for (int i = 0;; i++)
{
if (is->peek(is) != '"')
{
if (i >= size)
{
size *= 2;
a = realloc_aligned(a, size + sizeof(struct alloc));
s = (char *)(a + 1);
}
char c = is->get(is);
if (escape && c == 'n')
c = '\n';
else if (escape && c == '\\')
c = '\\';
if (c == '\\' && !escape)
{
escape = true;
i--; // will be incremented again, UGLY.
}
else
{
escape = false;
s[i] = c;
}
}
else
{
s[i] = '\0';
is->get(is);
*val = (value_t)s;
*val |= STRING_TAG;
add_this_alloc(a, STRING_TAG);
OKAY();
}
}
}
void printval_ol(value_t v)
{
// for (int i = 0; i < depth; i++)
// printf(" ");
if (symbolp(v))
{
printf("%s", (char *)(v ^ SYMBOL_TAG));
}
else if (stringp(v))
{
printf("\"%s\"", (char *)(v ^ STRING_TAG));
}
else if (integerp(v))
{
printf("%d", v >> 2);
}
else if (consp(v))
{
if (listp(v))
{
printf("(");
printval_ol(car(v));
for (value_t n = cdr(v); !nilp(n); n = cdr(n))
{
printf(" ");
printval_ol(car(n));
}
printf(")");
}
else
{
printf("(");
printval_ol(car(v));
printf(" . ");
printval_ol(cdr(v));
printf(")");
}
}
else if (nilp(v))
{
printf("nil\n");
}
else if (closurep(v))
{
struct closure *c = (void *)(v ^ CLOSURE_TAG);
printf("<closure %p (%d) %d>",
c->function, c->args->num_required, c->num_captured);
}
else
{
printf("<unknown %d>", v);
}
}
void printval(value_t v, int depth)
{
UNUSED(depth);
printval_ol(v);
printf("\n");
}
struct error readlist(struct istream *is, value_t *val)
{
E_INIT();
NEARIS(is);
skipws(is);
if (is->peek(is) != '(')
THROWSAFE(EEXPECTED);
is->get(is);
*val = readn(is);
skipws(is);
if (is->peek(is) != ')')
{
NEARIS(is);
THROW(EEXPECTED, "Unterminated list");
}
is->get(is);
OKAY();
}
struct error readint(struct istream *is, value_t *val)
{
E_INIT();
skipws(is);
int number = 0;
if (!isdigit(is->peek(is)))
THROWSAFE(EEXPECTED);
while (isdigit(is->peek(is)))
{
number *= 10;
number += is->get(is) - '0';
}
*val = intval(number);
OKAY();
}
struct error readquote(struct istream *is, value_t *val)
{
E_INIT();
skipws(is);
char c = is->peek(is);
if (c == '\'' || c == '`' || c == ',' || c == '#')
{
is->get(is);
if (c == ',' && is->peek(is) == '@')
{
// This is actually a splice
is->get(is);
c = '@';
}
else if (c == '#' && is->peek(is) == '\'')
{
is->get(is);
}
// Read the next form and wrap it in the appropriate function
value_t wrapped;
NEARIS(is);
struct error read_error = read1(is, &wrapped);
TRY_ELSE(read_error, EEXPECTED, "Expected a form after reader macro char %c", c);
value_t symbol = nil;
switch (c)
{
case '\'':
symbol = symval("quote");
break;
case '`':
symbol = symval("backquote");
break;
case ',':
symbol = symval("unquote");
break;
case '@':
symbol = symval("unquote-splice");
break;
case '#':
symbol = symval("function");
break;
default:
NEARIS(is);
THROW(EINVALID, "Invalid reader macro char %c", c);
}
*val = cons(symbol, cons(wrapped, nil));
OKAY();
}
else
{
THROWSAFE(EEXPECTED);
}
}
struct error read1(struct istream *is, value_t *val)
{
E_INIT();
NEARIS(is);
OKAY_IF(readquote(is, val));
OKAY_IF(readsym(is, val));
OKAY_IF(readstr(is, val));
OKAY_IF(readint(is, val));
OKAY_IF(readlist(is, val));
THROWSAFE(EEXPECTED);
}
void set_cons_info(value_t cons, int line, char *name)
{
if (!consp(cons))
return;
struct cons *ca = (void *)(cons ^ CONS_TAG);
ca->line = line;
ca->name = name;
}
value_t readn(struct istream *is)
{
value_t first = nil;
value_t *last = &first;
value_t read_val;
while (IS_OKAY(read1(is, &read_val)))
{
int line;
char *file;
is->getpos(is, &line, &file);
*last = cons(read_val, nil);
set_cons_info(*last, line, file);
last = cdrref(*last);
}
return first;
}
bool startswith(struct istream *s, char *pattern)
{
char *check = strdup(pattern);
s->read(s, check, strlen(pattern));
bool res = strcmp(check, pattern) == 0;
free(check);
return res;
}
static value_t strptrval(char *str, int tag)
{
value_t v;
struct alloc *al = malloc_aligned(strlen(str) + 1 + sizeof(struct alloc));
add_this_alloc(al, SYMBOL_TAG);
char *a = (char *)(al + 1);
strcpy(a, str);
v = (value_t)a;
v |= tag;
return v;
}
value_t strval(char *str)
{
return strptrval(str, STRING_TAG);
}
value_t symval(char *str)
{
return strptrval(str, SYMBOL_TAG);
}
bool integerp(value_t v)
{
return (v & INT_MASK) == INT_TAG;
}
bool symbolp(value_t v)
{
return (v & HEAP_MASK) == SYMBOL_TAG;
}
bool stringp(value_t v)
{
return (v & HEAP_MASK) == STRING_TAG;
}
bool consp(value_t v)
{
return (v & HEAP_MASK) == CONS_TAG;
}
bool heapp(value_t v)
{
return consp(v) || stringp(v) || symbolp(v) || closurep(v);
}
bool closurep(value_t v)
{
return (v & HEAP_MASK) == CLOSURE_TAG;
}
bool listp(value_t v)
{
value_t next = v;
while (consp(next))
{
next = cdr(next);
}
return nilp(next);
}
value_t car(value_t v)
{
if (!consp(v))
return nil;
return *carref(v);
}
value_t cdr(value_t v)
{
if (!consp(v))
return nil;
return *cdrref(v);
}
value_t *carref(value_t v)
{
if (!consp(v))
return NULL;
struct cons *c = (void *)(v ^ CONS_TAG);
return &c->car;
}
value_t *cdrref(value_t v)
{
if (!consp(v))
return NULL;
struct cons *c = (void *)(v ^ CONS_TAG);
return &c->cdr;
}
bool nilp(value_t v)
{
return v == nil;
}
int length(value_t v)
{
int i = 0;
for (; !nilp(v); v = cdr(v))
i++;
return i;
}
value_t elt(value_t v, int index)
{
for (int i = 0; i < index; i++)
{
v = cdr(v);
}
return car(v);
}
bool symstreq(value_t sym, char *str)
{
if ((sym & HEAP_MASK) != SYMBOL_TAG)
return false;
return strcmp((char *)(sym ^ SYMBOL_TAG), str) == 0;
}
unsigned char make_pool()
{
return ++max_pool;
}
unsigned char push_pool(unsigned char pool)
{
unsigned char old = current_pool;
current_pool = pool;
return old;
}
void pop_pool(unsigned char pool)
{
current_pool = pool;
}
bool pool_alive(unsigned char pool)
{
return pool != 0;
}
void add_to_pool(value_t form)
{
if (!heapp(form))
return;
struct alloc *a = (void *)(form & ~0b111);
a[-1].pool = current_pool;
}
void del_alloc(struct alloc *alloc)
{
if (alloc->type_tag == CLOSURE_TAG)
{
fprintf(stderr, "del_alloc closure\n");
struct closure_alloc *ca = alloc;
free(ca->closure.args);
}
free_aligned(alloc);
}
int cons_line(value_t val)
{
if (!consp(val))
return 0;
struct cons *c = (void *)(val ^ CONS_TAG);
return c->line;
}
char *cons_file(value_t val)
{
if (!consp(val))
return NULL;
struct cons *c = (void *)(val ^ CONS_TAG);
return c->name;
}
value_t create_closure(void *code, struct args *args, int ncaptures)
{
struct closure_alloc *ca = malloc_aligned(sizeof(struct closure_alloc) +
ncaptures * sizeof(value_t));
ca->closure.function = code;
ca->closure.args = args;
ca->closure.num_captured = ncaptures;
add_this_alloc(&ca->alloc, CLOSURE_TAG);
return (value_t)(&ca->closure) | CLOSURE_TAG;
}
void set_closure_capture_variable(int index, value_t value, value_t closure)
{
if (!closurep(closure))
return;
struct closure *c = (void *)(closure ^ CLOSURE_TAG);
c->data[index] = value;
}
value_t cxdr(value_t v, int index)
{
if (!listp(v) || index >= length(v))
return nil;
for (int i = 0; i < index; i++)
{
v = cdr(v);
}
return v;
}
value_t *cxdrref(value_t *v, int index)
{
if (!listp(*v) || index >= length(*v))
return NULL;
value_t *p = v;
for (int i = 0; i < index; i++)
{
p = cdrref(*p);
}
return p;
}
value_t deep_copy(value_t val)
{
if (integerp(val) || val == nil || val == t)
{
return val;
}
else if (symbolp(val))
{
return symval((char *)(val ^ SYMBOL_TAG));
}
else if (stringp(val))
{
return strval((char *)(val ^ STRING_TAG));
}
else if (consp(val))
{
return cons(deep_copy(car(val)), deep_copy(cdr(val)));
}
else if (closurep(val))
{
struct closure *c = (void *)(val ^ CLOSURE_TAG);
value_t new = create_closure(c->function, c->args, c->num_captured);
struct closure *new_c = (void *)(new ^ CLOSURE_TAG);
for (int i = 0; i < c->num_captured; i++)
{
new_c->data[i] = deep_copy(c->data[i]);
}
return new;
}
else
{
fprintf(stderr, "Don't know how to deep copy this, sorry... please report this bug :)");
return nil;
}
}
value_t *nilptr(value_t val)
{
if (!listp(val))
return NULL;
if (nilp(val))
return NULL;
value_t *p;
for (p = cdrref(val); !nilp(*p); p = cdrref(*p))
{
}
return p;
}
value_t merge2(value_t front, value_t back)
{
if (!listp(front) && listp(back))
return cons(front, back);
if (listp(front) && !listp(back))
back = cons(back, nil);
*nilptr(front) = back;
return front;
}