src/lisp/lisp.c

#include "lisp.h"
#include "plat/plat.h"

#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#define MIN(a, b) (a) > (b) ? (b) : (a)

struct alloc_list *first_a = NULL, *last_a = NULL;

value_t nil = 0b00101111; // magic ;)

void err (const char *msg)
{
	fprintf (stderr, "ERROR: %s\n", msg);
}

value_t intval (int i)
{
	i <<= 2;
	i |= INT_TAG;
	return i;
}

value_t cons (value_t car, value_t cdr)
{
	struct cons *c = malloc_aligned (sizeof (struct cons));

	c->car = car;
	c->cdr = cdr;

	struct alloc_list *item = malloc (sizeof (struct alloc_list));
	item->type = T_CONS;
	item->cons_val = c;

	if ( last_a )
	{
		item->prev = last_a;
		last_a->next = item;
		item->next = NULL;
	}
	else
	{
		item->prev = item->next = NULL;
		first_a = last_a = item;
	}

	value_t v = (value_t) c;
	v |= CONS_TAG;

	return v;
}

void skipws (struct istream *is)
{
	while ( isspace (is->peek (is)) )
		is->get (is);
}

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);
}

bool readsym (struct istream *is, value_t *val)
{
	skipws (is);

	if ( !issymstart (is->peek (is)) )
		return false;

	int size = 8;
	char *s = malloc_aligned (size);

	s[ 0 ] = is->get (is);

	for ( int i = 1;; i++ )
	{
		if ( issym (is->peek (is)) )
		{
			if ( i >= size )
			{
				size *= 2;
				s = realloc_aligned (s, size);
			}

			s[ i ] = is->get (is);
		}
		else
		{
			s[ i ] = 0;
			*val = (value_t) s;
			*val |= SYMBOL_TAG;

			return true;
		}
	}
}

bool readstr (struct istream *is, value_t *val)
{
	skipws (is);

	if ( is->peek (is) != '"' )
		return false;

	bool escape = false;
	int size = 8;
	char *s = malloc_aligned (size);

	(void)is->get (is);

	for ( int i = 0;; i++ )
	{
		if ( is->peek (is) != '"' )
		{
			if ( i >= size )
			{
				size *= 2;
				s = realloc_aligned (s, size);
			}

			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
		{
			is->get (is);

			*val = (value_t) s;
			*val |= STRING_TAG;

			return true;
		}
	}
}

void printval (value_t v, int depth)
{
	for ( int i = 0; i < depth; i++ )
		printf ("  ");

	if ( symbolp (v) )
	{
		printf ("'%s\n", (char *) (v ^ SYMBOL_TAG));
	}
	else if ( stringp (v) )
	{
		printf ("\"%s\"\n", (char *) (v ^ STRING_TAG));
	}
	else if ( consp (v) )
	{
		if ( listp (v) )
		{
			printf ("list:\n");

			for ( value_t n = v; !nilp (n); n = cdr (n) )
			{
				printval (car (n), depth + 1);
			}
		}
		else
		{
			printf ("cons:\n");
			printval (car (v), depth + 1);
			printval (cdr (v), depth + 1);
		}
	}
	else if ( nilp (v) )
	{
		printf ("nil\n");
	}
	else
	{
		printf ("<unknown %d>\n", v);
	}
}

bool readlist (struct istream *is, value_t *val)
{
	skipws (is);

	if ( is->peek (is) != '(' )
		return false;

	is->get (is);

	*val = readn (is);

	if ( is->peek (is) != ')' )
	{
		is->showpos (is, stderr);
		err ("Unterminated list");
		return false;
	}
	is->get (is);

	return true;
}

bool read1 (struct istream *is, value_t *val)
{
	if ( readsym (is, val) )
		return true;

	if ( readstr (is, val) )
		return true;

	if ( readlist (is, val) )
		return true;

	return false;
}

value_t readn (struct istream *is)
{
	value_t first = nil;
	value_t *last = &first;

	value_t read_val;

	while ( read1 (is, &read_val) )
	{
		*last = cons (read_val, nil);
		last = cdrref (*last);
	}

	return first;
}

struct stristream_private
{
	char *val;
	int i;
	int length;
	int line;
	int fromleft;
	int linestart;
};

int stristream_peek (struct istream *is)
{
	struct stristream_private *p = is->data;

	if ( p->i < p->length )
		return p->val[ p->i ];
	else
		return -1;
}

int stristream_get (struct istream *is)
{
	struct stristream_private *p = is->data;

	if ( p->i < p->length )
	{
		char c = p->val[ p->i++ ];

		p->fromleft++;

		if ( c == '\n' )
		{
			p->fromleft = 1;
			p->line++;
			p->linestart = p->i;
		}

		return c;
	}
	else
		return -1;
}

int stristream_read (struct istream *s, char *buffer, int size)
{
	struct stristream_private *p = s->data;

	int len = MIN (size, p->length - p->i);
	memcpy (buffer, p->val, len);
	return len;
}

void stristream_showpos (struct istream *s, FILE *out)
{
	struct stristream_private *p = s->data;

	fprintf (out, "line: %d, char %d\n", p->line, p->fromleft);

	int end = p->length;

	for ( int i = p->linestart; i < p->length; i++ )
	{
		if ( p->val[ i ] == '\n' )
		{
			end = i;
			break;
		}
	}

	fprintf (out, "  | %.*s\n", end - p->linestart, p->val + p->linestart);
	fprintf (out, "  | ");
	for ( int i = 0; i < p->fromleft - 1; i++ )
		fprintf (out, " ");

	fprintf (out, "\033[31m^\033[0m\n");
}

struct istream *new_stristream (char *str, int length)
{
	struct istream *is = malloc (sizeof (struct istream));
	struct stristream_private *p = malloc (sizeof (struct stristream_private));

	p->val = strndup (str, length);
	p->i = 0;
	p->length = length;
	p->line = 1;
	p->fromleft = 1;
	p->linestart = 0;

	is->data = p;
	is->get = stristream_get;
	is->peek = stristream_peek;
	is->read = stristream_read;
	is->showpos = stristream_showpos;

	return is;
}

void del_stristream (struct istream *stristream)
{
	struct stristream_private *p = stristream->data;
	free (p->val);
	free (p);
	free (stristream);
}

struct istream *new_stristream_nt (char *str)
{
	return new_stristream (str, strlen (str));
}

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;
}

value_t strval (char *str)
{
	value_t v;

	char *a = malloc_aligned (strlen (str) + 1);
	v = (value_t) a;
	v |= STRING_TAG;

	return v;
}

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 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;

	FOREACH (item, v)
	{
		(void) item;
		i++;
	}

	return i;
}