Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-06-28 16:47:23 +09:00
commit 5b6bd50f45
10 changed files with 2007 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

552
src/lisp.c Normal file
View File

@ -0,0 +1,552 @@
#include "lisp.h"
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
#include <string.h>
struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_NULL] = {"null", sizeof("null") - 1},
[TYPE_STRING] = {"string", sizeof("string") - 1},
[TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1},
[TYPE_PAIR] = {"pair", sizeof("pair") - 1},
[TYPE_INTEGER] = {"integer", sizeof("integer") - 1},
[TYPE_FLOAT] = {"float", sizeof("float") - 1},
[TYPE_VECTOR] = {"vector", sizeof("vector") - 1},
[TYPE_FUNCTION] = {"function", sizeof("function") - 1},
[TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
};
LispVal _Qnil = {
.type = TYPE_NULL,
.ref_count = -1,
};
DEF_STATIC_STRING(_Qunbound_name, "unbound");
LispSymbol _Qunbound = {
.type = TYPE_SYMBOL,
.ref_count = -1,
.name = &_Qunbound_name,
.plist = Qnil,
.function = Qunbound,
.value = Qunbound,
};
DEF_STATIC_STRING(_Qt_name, "t");
LispSymbol _Qt = {
.type = TYPE_SYMBOL,
.ref_count = -1,
.name = &_Qt_name,
.plist = Qnil,
.function = Qunbound,
.value = Qunbound,
};
DEF_STATIC_SYMBOL(quote, "'");
DEF_STATIC_SYMBOL(backquote, "`");
DEF_STATIC_SYMBOL(comma, ",");
void _internal_lisp_delete_object(LispVal *val) {
switch (TYPEOF(val)) {
case TYPE_NULL:
case TYPE_INTEGER:
case TYPE_FLOAT:
lisp_free(val);
break;
case TYPE_STRING: {
LispString *str = (LispString *) val;
if (!str->is_static) {
lisp_free(str->data);
}
lisp_free(val);
} break;
case TYPE_SYMBOL: {
LispSymbol *sym = (LispSymbol *) val;
lisp_unref(sym->name);
lisp_unref(sym->plist);
lisp_unref(sym->function);
lisp_unref(sym->value);
lisp_free(val);
} break;
case TYPE_PAIR:
lisp_unref(((LispPair *) val)->head);
lisp_unref(((LispPair *) val)->tail);
lisp_free(val);
break;
case TYPE_VECTOR: {
LispVector *vec = (LispVector *) val;
for (size_t i = 0; i < vec->length; ++i) {
lisp_unref(vec->data[i]);
}
lisp_free(vec->data);
lisp_free(val);
} break;
case TYPE_FUNCTION:
// TODO handle
break;
case TYPE_HASHTABLE: {
LispHashtable *tbl = (LispHashtable *) val;
for (size_t i = 0; i < tbl->table_size; ++i) {
struct HashtableBucket *cur = tbl->data[i];
while (cur) {
lisp_unref(cur->key);
lisp_unref(cur->value);
struct HashtableBucket *next = cur->next;
lisp_free(cur);
cur = next;
}
}
lisp_free(tbl->data);
lisp_unref(tbl->eq_fn);
lisp_unref(tbl->hash_fn);
lisp_free(val);
} break;
default:
abort();
};
}
void *lisp_malloc(size_t size) {
return lisp_realloc(NULL, size);
}
void *lisp_realloc(void *old_ptr, size_t size) {
if (!size) {
return NULL;
}
void *new_ptr = realloc(old_ptr, size);
if (!new_ptr) {
abort();
}
return new_ptr;
}
char *lisp_strdup(const char *str) {
size_t len = strlen(str);
char *new_str = lisp_malloc(len + 1);
memcpy(new_str, str, len + 1);
return new_str;
}
LispVal *make_lisp_string(const char *data, size_t length, bool take,
bool is_static) {
LispString *self = lisp_malloc(sizeof(LispString));
self->type = TYPE_STRING;
self->ref_count = 0;
if (take) {
self->data = (char *) data;
} else {
self->data = lisp_strdup(data);
}
self->length = length;
self->is_static = is_static;
return LISPVAL(self);
}
LispVal *sprintf_lisp(const char *format, ...) {
va_list args;
va_start(args, format);
va_list args_measure;
va_copy(args_measure, args);
int size = vsnprintf(NULL, 0, format, args_measure) + 1;
va_end(args_measure);
char *buffer = lisp_malloc(size);
vsnprintf(buffer, size, format, args);
LispVal *obj = make_lisp_string(buffer, size, true, false);
va_end(args);
return obj;
}
LispVal *make_lisp_symbol(LispVal *name) {
LispSymbol *self = lisp_malloc(sizeof(LispSymbol));
self->type = TYPE_SYMBOL;
self->ref_count = 0;
self->name = (LispString *) lisp_ref(name);
self->plist = Qnil;
self->function = Qunbound;
self->value = Qunbound;
return LISPVAL(self);
}
LispVal *make_lisp_pair(LispVal *head, LispVal *tail) {
LispPair *self = lisp_malloc(sizeof(LispPair));
self->type = TYPE_PAIR;
self->ref_count = 0;
self->head = lisp_ref(head);
self->tail = lisp_ref(tail);
return LISPVAL(self);
}
LispVal *make_lisp_integer(intmax_t value) {
LispInteger *self = lisp_malloc(sizeof(LispInteger));
self->type = TYPE_INTEGER;
self->ref_count = 0;
self->value = value;
return LISPVAL(self);
}
LispVal *make_lisp_float(long double value) {
LispFloat *self = lisp_malloc(sizeof(LispFloat));
self->type = TYPE_FLOAT;
self->ref_count = 0;
self->value = value;
return LISPVAL(self);
}
LispVal *make_lisp_vector(LispVal **data, size_t length) {
LispVector *self = lisp_malloc(sizeof(LispVector));
self->type = TYPE_VECTOR;
self->ref_count = 0;
self->data = data;
self->length = length;
return LISPVAL(self);
}
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) {
LispHashtable *self = lisp_malloc(sizeof(LispHashtable));
self->type = TYPE_HASHTABLE;
self->ref_count = 0;
self->table_size = LISP_HASHTABLE_INITIAL_SIZE;
self->data =
lisp_malloc(sizeof(struct HashtableBucket *) * self->table_size);
memset(self->data, 0, sizeof(struct HashtableBucket *) * self->table_size);
self->count = 0;
self->eq_fn = eq_fn;
self->hash_fn = hash_fn;
return LISPVAL(self);
}
DEFUN(type_of, "type-of", (LispVal * obj)) {
if (obj->type < 0 || obj->type >= N_LISP_TYPES) {
return Qnil;
}
LispVal *name =
make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
LISP_TYPE_NAMES[obj->type].len, true, true);
lisp_ref(name);
LispVal *sym = Fintern(name);
UNREF_INPLACE(name);
return sym;
}
DEFUN(pair, "pair", (LispVal * head, LispVal *tail)) {
return make_lisp_pair(head, tail);
}
DEFUN(hash_string, "hash-string", (LispVal * obj)) {
CHECK_TYPE(TYPE_STRING, obj);
const char *str = ((LispString *) obj)->data;
uint64_t hash = 5381;
int c;
while ((c = *(str++))) {
hash = ((hash << 5) + hash) + c;
}
return make_lisp_integer(hash);
}
DEFUN(strings_equal, "strings-equal", (LispVal * obj1, LispVal *obj2)) {
CHECK_TYPE(TYPE_STRING, obj1);
CHECK_TYPE(TYPE_STRING, obj2);
LispString *str1 = (LispString *) obj1;
LispString *str2 = (LispString *) obj2;
if (str1->length != str2->length) {
return Qnil;
}
return LISP_BOOL(memcmp(str1->data, str2->data, str1->length) == 0);
}
bool strings_equal_nocase(const char *s1, const char *s2, size_t n) {
for (size_t i = 0; i < n; ++i) {
if (!s1[i] || !s2[i]) {
return !s1[i] && !s2[i];
} else if (tolower(s1[i]) != tolower(s2[i])) {
return false;
}
}
return true;
}
DEFUN(id, "id", (LispVal * obj)) {
return make_lisp_integer((int64_t) obj);
}
DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2)) {
return LISP_BOOL(obj1 == obj2);
}
static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
if (NILP(self->eq_fn)) {
return v1 == v2;
} else if (self->eq_fn == Qstrings_equal) {
return !NILP(Fstrings_equal(v1, v2));
} else {
// TODO call the function
return false;
}
}
static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
if (NILP(self->hash_fn)) {
return (uint64_t) key;
} else if (self->hash_fn == Qhash_string) {
// Make obarray lookups faster
LispVal *hash_obj = Fhash_string(key);
uint64_t hash = ((LispInteger *) hash_obj)->value;
UNREF_INPLACE(hash_obj);
return hash;
} else {
// TODO call the hash function
return 0;
}
}
static struct HashtableBucket *
find_hash_table_bucket(LispHashtable *self, LispVal *key, uint64_t hash) {
struct HashtableBucket *cur = self->data[hash % self->table_size];
while (cur) {
if (hash_table_eq(self, key, cur->key)) {
return cur;
}
cur = cur->next;
}
return NULL;
}
static void hash_table_rehash(LispHashtable *self, size_t new_size) {
struct HashtableBucket **new_data =
lisp_malloc(sizeof(struct HashtableBucket *) * new_size);
memset(new_data, 0, sizeof(struct HashtableBucket *) * new_size);
for (size_t i = 0; i < self->table_size; ++i) {
struct HashtableBucket *cur = self->data[i];
while (cur) {
struct HashtableBucket *next = cur->next;
cur->next = new_data[cur->hash % new_size];
new_data[cur->hash % new_size] = cur;
cur = next;
}
}
free(self->data);
self->data = new_data;
self->table_size = new_size;
}
DEFUN(puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value)) {
CHECK_TYPE(TYPE_HASHTABLE, table);
LispHashtable *self = (LispHashtable *) table;
uint64_t hash = hash_table_hash(self, key);
struct HashtableBucket *cur_bucket =
find_hash_table_bucket(self, key, hash);
if (cur_bucket) {
UNREF_INPLACE(cur_bucket->value);
cur_bucket->value = lisp_ref(value);
} else {
cur_bucket = lisp_malloc(sizeof(struct HashtableBucket));
cur_bucket->next = self->data[hash % self->table_size];
cur_bucket->hash = hash;
cur_bucket->key = lisp_ref(key);
cur_bucket->value = lisp_ref(value);
self->data[hash % self->table_size] = cur_bucket;
++self->count;
if ((double) self->count / self->table_size
>= LISP_HASHTABLE_GROWTH_THRESHOLD) {
hash_table_rehash(self,
LISP_HASHTABLE_GROWTH_FACTOR * self->table_size);
}
}
return table;
}
DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def)) {
CHECK_TYPE(TYPE_HASHTABLE, table);
LispHashtable *self = (LispHashtable *) table;
uint64_t hash = hash_table_hash(self, key);
struct HashtableBucket *cur_bucket =
find_hash_table_bucket(self, key, hash);
if (cur_bucket) {
return cur_bucket->value;
}
return def;
}
DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) {
CHECK_TYPE(TYPE_HASHTABLE, table);
LispHashtable *self = (LispHashtable *) table;
uint64_t hash = hash_table_hash(self, key);
struct HashtableBucket *cur_bucket = self->data[hash % self->table_size];
if (cur_bucket && hash_table_eq(self, cur_bucket->key, key)) {
self->data[hash % self->table_size] = cur_bucket->next;
UNREF_INPLACE(cur_bucket->key);
UNREF_INPLACE(cur_bucket->value);
free(cur_bucket);
--self->count;
} else {
struct HashtableBucket *prev_bucket = cur_bucket;
cur_bucket = cur_bucket->next;
while (cur_bucket) {
if (hash_table_eq(self, cur_bucket->key, key)) {
prev_bucket->next = cur_bucket->next;
UNREF_INPLACE(cur_bucket->key);
UNREF_INPLACE(cur_bucket->value);
free(cur_bucket);
--self->count;
break;
}
}
}
if ((double) self->count / self->table_size
<= LISP_HASHTABLE_SHRINK_THRESHOLD
&& self->table_size > LISP_HASHTABLE_INITIAL_SIZE) {
hash_table_rehash(self,
self->table_size / LISP_HASHTABLE_GROWTH_FACTOR);
}
return table;
}
DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) {
CHECK_TYPE(TYPE_HASHTABLE, table);
return make_lisp_integer(((LispHashtable *) table)->count);
}
DEFUN(intern, "intern", (LispVal * name)) {
CHECK_TYPE(TYPE_STRING, name);
LispVal *cur = Fgethash(Vobarray, name, Qunbound);
if (cur != Qunbound) {
return cur;
}
LispVal *sym = make_lisp_symbol(name);
Fputhash(Vobarray, name, sym);
return sym;
}
LispVal *intern(const char *name, size_t length, bool take) {
LispVal *name_obj = make_lisp_string((char *) name, length, take, false);
lisp_ref(name_obj);
LispVal *sym = Fintern(name_obj);
UNREF_INPLACE(name_obj);
return sym;
}
DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head)) {
CHECK_TYPE(TYPE_PAIR, pair);
UNREF_INPLACE(((LispPair *) pair)->head);
((LispPair *) pair)->head = lisp_ref(head);
return Qnil;
}
DEFUN(settail, "settail", (LispVal * pair, LispVal *tail)) {
CHECK_TYPE(TYPE_PAIR, pair);
UNREF_INPLACE(((LispPair *) pair)->tail);
((LispPair *) pair)->tail = lisp_ref(tail);
return Qnil;
}
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
if (!SYMBOLP(signal)) {
printf("Attempt to throw non-symbol value!\n");
} else {
LispSymbol *sym = (LispSymbol *) signal;
printf("Throw %*s! Data: ", (int) sym->name->length, sym->name->data);
debug_dump(stdout, rest, true);
}
return Qnil;
}
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
LispVal *Vobarray = Qnil;
void lisp_init() {
Vobarray = lisp_ref(make_lisp_hashtable(Qstrings_equal, Qhash_string));
}
void lisp_shutdown() {
UNREF_INPLACE(Vobarray);
}
static void debug_dump_real(FILE *stream, void *obj, bool first) {
switch (TYPEOF(obj)) {
case TYPE_NULL:
fprintf(stream, "nil");
break;
case TYPE_STRING: {
LispString *str = (LispString *) obj;
// TODO actually quote
fputc('"', stream);
fwrite(str->data, 1, str->length, stream);
fputc('"', stream);
} break;
case TYPE_SYMBOL: {
LispSymbol *sym = (LispSymbol *) obj;
fwrite(sym->name->data, 1, sym->name->length, stream);
} break;
case TYPE_PAIR: {
LispPair *pair = (LispPair *) obj;
if (first) {
fputc('(', stream);
} else {
fputc(' ', stream);
}
debug_dump_real(stream, pair->head, true);
if (NILP(pair->tail)) {
fputc(')', stream);
} else if (PAIRP(pair->tail)) {
debug_dump_real(stream, pair->tail, false);
} else {
fprintf(stream, " . ");
debug_dump_real(stream, pair->tail, false);
fputc(')', stream);
}
} break;
case TYPE_INTEGER:
fprintf(stream, "%jd", ((LispInteger *) obj)->value);
break;
case TYPE_FLOAT:
fprintf(stream, "%Lf", ((LispFloat *) obj)->value);
break;
case TYPE_VECTOR: {
LispVector *vec = (LispVector *) obj;
fputc('[', stream);
for (size_t i = 0; i < vec->length; ++i) {
if (i) {
fputc(' ', stream);
}
debug_dump_real(stream, vec->data[i], true);
}
fputc(']', stream);
} break;
case TYPE_FUNCTION:
if (((LispFunction *) obj)->builtin) {
fprintf(stream, "<builtin at %#jx>", (uintmax_t) obj);
} else {
fprintf(stream, "<function at %#jx>", (uintmax_t) obj);
}
break;
case TYPE_HASHTABLE: {
LispHashtable *tbl = (LispHashtable *) obj;
fprintf(stream, "<hashtable size=%zu count=%zu at %#jx>",
tbl->table_size, tbl->count, (uintmax_t) obj);
} break;
default:
fprintf(stream, "<object type=%ju at %#jx>",
(uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj);
break;
}
}
void debug_dump(FILE *stream, void *obj, bool newline) {
debug_dump_real(stream, obj, true);
if (newline) {
fputc('\n', stream);
}
}
void debug_print_hashtable(FILE *stream, LispVal *table) {
debug_dump(stream, table, true);
HASHTABLE_FOREACH(key, val, table, {
fprintf(stream, "- ");
debug_dump(stream, key, false);
fprintf(stream, " = ");
debug_dump(stream, val, true);
});
}

326
src/lisp.h Normal file
View File

@ -0,0 +1,326 @@
#ifndef INCLUDED_LISP_H
#define INCLUDED_LISP_H
#include <stdarg.h>
#include <stdbool.h>
#include <stddef.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#if __has_attribute(format)
# define PRINTF_FORMAT(first, second) \
__attribute__((format(printf, first, second)))
#else
# define PRINTF_FORMAT(first, second)
#endif
typedef enum {
TYPE_NULL = 0,
TYPE_STRING,
TYPE_SYMBOL,
TYPE_PAIR,
TYPE_INTEGER,
TYPE_FLOAT,
TYPE_VECTOR,
TYPE_FUNCTION,
TYPE_HASHTABLE,
N_LISP_TYPES,
} LispType;
struct _TypeNameEntry {
const char *name;
size_t len;
};
extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES];
#define OBJ_TYPE_NAME(obj) (LISP_TYPE_NAMES[LISPVAL(obj)->type].name)
#define LISP_OBJECT_HEADER \
LispType type; \
ptrdiff_t ref_count;
typedef struct {
LISP_OBJECT_HEADER;
} LispVal;
#define LISPVAL(obj) ((LispVal *) (obj))
#define STATICP(v) (LISPVAL(v)->ref_count < 0)
#define TYPEOF(v) (LISPVAL(v)->type)
typedef struct {
LISP_OBJECT_HEADER;
char *data;
size_t length;
bool is_static;
} LispString;
typedef struct {
LISP_OBJECT_HEADER;
LispString *name;
LispVal *plist;
LispVal *function;
LispVal *value;
} LispSymbol;
typedef struct {
LISP_OBJECT_HEADER;
LispVal *head;
LispVal *tail;
} LispPair;
typedef struct {
LISP_OBJECT_HEADER;
intmax_t value;
} LispInteger;
typedef struct {
LISP_OBJECT_HEADER;
long double value;
} LispFloat;
typedef struct {
LISP_OBJECT_HEADER;
LispVal **data;
size_t length;
} LispVector;
typedef LispVal *(*lisp_builtin_t)();
typedef struct {
LISP_OBJECT_HEADER;
LispVal *doc;
LispVal *args;
bool is_builtin;
union {
LispVal *body;
lisp_builtin_t builtin;
};
} LispFunction;
struct HashtableBucket {
struct HashtableBucket *next;
uint64_t hash;
LispVal *key;
LispVal *value;
};
#define LISP_HASHTABLE_INITIAL_SIZE 32
#define LISP_HASHTABLE_GROWTH_FACTOR 2
#define LISP_HASHTABLE_GROWTH_THRESHOLD 0.75f
#define LISP_HASHTABLE_SHRINK_THRESHOLD 0.25f
typedef struct {
LISP_OBJECT_HEADER;
struct HashtableBucket **data;
size_t table_size;
size_t count;
LispVal *eq_fn;
LispVal *hash_fn;
} LispHashtable;
#define NILP(v) (TYPEOF(v) == TYPE_NULL)
#define STRINGP(v) (TYPEOF(v) == TYPE_STRING)
#define SYMBOLP(v) (TYPEOF(v) == TYPE_SYMBOL)
#define PAIRP(v) (TYPEOF(v) == TYPE_PAIR)
#define INTEGERP(v) (TYPEOF(v) == TYPE_INTEGER)
#define FLOATP(v) (TYPEOF(v) == TYPE_FLOAT)
#define VECTORP(v) (TYPEOF(v) == TYPE_VECTOR)
#define FUNCTIONP(v) (TYPEOF(v) == TYPE_FUNCTION)
#define HASHTABLEP(v) (TYPEOF(v) == TYPE_HASHTABLE)
#define ATOM(v) (TYPEOF(v) != TYPE_PAIR)
inline static bool LISTP(LispVal *v) {
return NILP(v) || PAIRP(v);
}
inline static bool NUMBERP(LispVal *v) {
return INTEGERP(v) || FLOATP(v);
}
extern LispVal _Qnil;
extern LispSymbol _Qunbound;
extern LispSymbol _Qt;
#define Qnil (&_Qnil)
#define Qunbound (LISPVAL(&_Qunbound))
#define Qt (LISPVAL(&_Qt))
extern LispVal *Qquote;
extern LispVal *Qbackquote;
extern LispVal *Qcomma;
#define LISP_BOOL(v) ((v) ? Qt : Qnil)
#define DEF_STATIC_STRING(name, value) \
static LispString name = { \
.type = TYPE_STRING, \
.ref_count = -1, \
.data = value, \
.length = sizeof(value) - 1, \
.is_static = true, \
};
#define DEF_STATIC_SYMBOL(c_name, lisp_name) \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \
.ref_count = -1, \
.name = &_Q##c_name##_name, \
.plist = Qnil, \
.function = Qunbound, \
.value = Qunbound, \
}; \
LispVal *Q##c_name = LISPVAL(&_Q##c_name);
void *lisp_malloc(size_t size);
void *lisp_realloc(void *old_ptr, size_t size);
#define lisp_free free
char *lisp_strdup(const char *str);
inline static void *lisp_ref(void *val) {
if (!STATICP(val)) {
++((LispVal *) val)->ref_count;
}
return val;
}
inline static void *lisp_float_ref(void *val) {
if (LISPVAL(val)->ref_count > 0) {
--LISPVAL(val)->ref_count;
}
return val;
}
void _internal_lisp_delete_object(LispVal *val);
inline static void *lisp_unref(void *val) {
if (STATICP(val)) {
return val;
} else if (LISPVAL(val)->ref_count > 1) {
--LISPVAL(val)->ref_count;
return val;
} else {
_internal_lisp_delete_object(val);
return Qnil;
}
}
#define UNREF_INPLACE(variable) \
{ \
variable = lisp_unref(variable); \
}
LispVal *make_lisp_string(const char *data, size_t length, bool take,
bool is_static);
#define STATIC_STRING(s) (make_lisp_string((s), sizeof(s) - 1, true, true))
LispVal *sprintf_lisp(const char *format, ...) PRINTF_FORMAT(1, 2);
LispVal *make_lisp_symbol(LispVal *name);
LispVal *make_lisp_pair(LispVal *head, LispVal *tail);
LispVal *make_lisp_integer(intmax_t value);
LispVal *make_lisp_float(long double value);
LispVal *make_lisp_vector(LispVal **data, size_t length);
// TODO make_lisp_function
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
#define DECLARE_FUNCTION(c_name, args) \
extern LispVal *Q##c_name; \
LispVal *F##c_name args;
// The args and doc fields are filled when the function is registered
#define DEFUN(c_name, lisp_name, c_args) \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
static LispFunction _Q##c_name##_function = { \
.type = TYPE_FUNCTION, \
.ref_count = -1, \
.doc = Qnil, \
.args = Qnil, \
.is_builtin = true, \
.builtin = &F##c_name, \
}; \
static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \
.ref_count = -1, \
.name = &_Q##c_name##_name, \
.plist = Qnil, \
.function = LISPVAL(&_Q##c_name##_function), \
}; \
LispVal *Q##c_name = (LispVal *) &_Q##c_name; \
LispVal *F##c_name c_args
DECLARE_FUNCTION(type_of, (LispVal * obj));
DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail));
DECLARE_FUNCTION(hash_string, (LispVal * obj));
DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2));
bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
DECLARE_FUNCTION(id, (LispVal * obj));
DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2));
DECLARE_FUNCTION(puthash, (LispVal * table, LispVal *key, LispVal *value));
DECLARE_FUNCTION(gethash, (LispVal * table, LispVal *key, LispVal *def));
DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key));
DECLARE_FUNCTION(hash_table_count, (LispVal * table));
#define HASHTABLE_FOREACH(key_var, val_var, table, body) \
{ \
LispHashtable *__hashtable_foreach_table = (LispHashtable *) table; \
for (size_t __hashtable_foreach_i = 0; \
__hashtable_foreach_i < __hashtable_foreach_table->count; \
++__hashtable_foreach_i) { \
struct HashtableBucket *__hashtable_foreach_cur = \
__hashtable_foreach_table->data[__hashtable_foreach_i]; \
while (__hashtable_foreach_cur) { \
LispVal *key_var = __hashtable_foreach_cur->key; \
LispVal *val_var = __hashtable_foreach_cur->value; \
{body}; \
__hashtable_foreach_cur = __hashtable_foreach_cur->next; \
} \
} \
}
DECLARE_FUNCTION(intern, (LispVal * name));
LispVal *intern(const char *name, size_t length, bool take);
#define INTERN_STATIC(name) (Fintern(STATIC_STRING(name)))
DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head));
DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail));
static inline LispVal *make_list(int len, ...) {
LispVal *list = Qnil;
LispVal *end;
va_list args;
va_start(args, len);
while (len--) {
LispVal *elt = va_arg(args, LispVal *);
if (NILP(list)) {
list = Fpair(elt, Qnil);
end = list;
} else {
LispVal *new_end = Fpair(elt, Qnil);
Fsettail(end, new_end);
end = new_end;
}
}
va_end(args);
return list;
}
DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
extern LispVal *Qtype_error;
extern LispVal *Qread_error;
#define CHECK_TYPE(type, val) \
if (TYPEOF(val) != type) { \
Fthrow(Qtype_error, Qnil); \
return Qnil; \
}
extern LispVal *Vobarray;
void lisp_init(void);
void lisp_shutdown(void);
void debug_dump(FILE *stream, void *obj, bool newline);
void debug_print_hashtable(FILE *stream, LispVal *table);
#endif

18
src/main.c Normal file
View File

@ -0,0 +1,18 @@
#include "lisp.h"
#include "read.h"
#include <string.h>
int main(int argc, const char **argv) {
lisp_init();
char buffer[] = "1";
LispVal *tv;
size_t count = read_from_buffer(buffer, sizeof(buffer) - 1, &tv);
lisp_ref(tv);
printf("Read %zu chars\n", count);
printf("Type: %s\n", OBJ_TYPE_NAME(tv));
debug_dump(stdout, tv, true);
UNREF_INPLACE(tv);
lisp_shutdown();
return 0;
}

404
src/read.c Normal file
View File

@ -0,0 +1,404 @@
#include "read.h"
#include <ctype.h>
#include <inttypes.h>
#include <limits.h>
#include <string.h>
struct ReadState {
const char *head;
size_t left;
size_t off;
size_t line;
size_t col;
size_t backquote_level;
};
#define EOS -1
static int popc(struct ReadState *state) {
if (!state->left) {
return EOS;
}
++state->off;
--state->left;
int c = *(state->head++);
if (c == '\n') {
++state->line;
state->off = 0;
} else {
++state->col;
}
return c;
}
static int peekc(struct ReadState *state) {
if (!state->left) {
return EOS;
}
return *state->head;
}
static inline void _internal_read_error(struct ReadState *state, size_t len,
LispVal *desc) {
// TODO format better
LispVal *args = make_list(
4, make_lisp_integer(state->line), make_lisp_integer(state->col),
make_lisp_string(state->head, len, false, false), desc);
lisp_ref(args);
Fthrow(Qread_error, args);
UNREF_INPLACE(args);
}
#define READ_ERROR(state, len, ...) \
_internal_read_error(state, len, sprintf_lisp(__VA_ARGS__))
#define EOF_ERROR(state) READ_ERROR(state, 1, "unexpected end of file")
#define SKIP_WHILE(cond, state) \
while (cond) { \
popc(state); \
}
#define SKIP_WHITESPACE(state) SKIP_WHILE(isblank(peekc(state)), state)
static bool is_symbol_end(int c) {
return c == EOS || isspace(c) || c == '(' || c == ')' || c == '['
|| c == ']';
}
static LispVal *read_internal(struct ReadState *state);
static LispVal *read_list(struct ReadState *state) {
popc(state); // open (
LispVal *list = Qnil;
LispVal *end = list;
SKIP_WHITESPACE(state);
int c;
while ((c = peekc(state)) != ')') {
if (c == EOS) {
EOF_ERROR(state);
UNREF_INPLACE(list);
return Qnil;
}
LispVal *elt = read_internal(state);
if (NILP(list)) {
list = Fpair(elt, Qnil);
end = list;
} else {
LispVal *new_end = Fpair(elt, Qnil);
Fsettail(end, new_end);
end = new_end;
}
SKIP_WHITESPACE(state);
}
popc(state); // close )
return list;
}
static LispVal *read_vector(struct ReadState *state) {
popc(state); // open [
LispVal **values = NULL;
size_t values_len = 0;
SKIP_WHITESPACE(state);
int c;
while ((c = peekc(state)) != ']') {
if (c == EOS) {
EOF_ERROR(state);
for (size_t i = 0; i < values_len; ++i) {
lisp_unref(values[i]);
}
lisp_free(values);
return Qnil;
}
LispVal *elt = lisp_ref(read_internal(state));
values = lisp_realloc(values, sizeof(LispVal *) * ++values_len);
values[values_len - 1] = elt;
SKIP_WHITESPACE(state);
}
popc(state); // close ]
return make_lisp_vector(values, values_len);
}
static LispVal *read_string(struct ReadState *state) {
popc(state); // open "
bool backslash = false;
int c;
char *str = lisp_malloc(1);
size_t str_len = 0;
while (backslash || (c = peekc(state)) != '"') {
if (c == EOS) {
lisp_free(str);
EOF_ERROR(state);
return Qnil;
}
popc(state);
if (!backslash && c == '\\') {
backslash = true;
} else if (backslash && c == '\n') {
backslash = false;
} else {
str = lisp_realloc(str, ++str_len + 1);
int to_add = c;
if (backslash) {
switch (c) {
case 'n':
to_add = '\n';
break;
case 't':
to_add = '\t';
break;
case 'r':
to_add = '\r';
break;
case '0':
to_add = '\0';
break;
case '"':
to_add = '"';
break;
default:
// TODO make this point at the correct thing
READ_ERROR(state, 1, "unknown escape sequence");
lisp_free(str);
return Qnil;
}
}
backslash = false;
str[str_len - 1] = to_add;
}
}
str[str_len] = '\n';
popc(state); // close "
return make_lisp_string(str, str_len, true, false);
}
static LispVal *read_character(struct ReadState *state) {
static struct {
const char *name;
size_t len;
char value;
} LOOKUP_TABLE[] = {
{"null", 4, '\0'}, {"\\0", 2, '\0'}, {"newline", 7, '\n'},
{"\\n", 2, '\n'}, {"tab", 3, '\t'}, {"\\t", 2, '\t'},
};
#define LOOKUP_TABLE_SIZE (sizeof(LOOKUP_TABLE) / sizeof(LOOKUP_TABLE[0]))
struct ReadState start_state = *state;
popc(state); // #
const char *start = state->head;
while (!is_symbol_end(peekc(state))) {
popc(state);
}
size_t len = state->head - start;
for (size_t i = 0; i < LOOKUP_TABLE_SIZE; ++i) {
if (len == LOOKUP_TABLE[i].len
&& strings_equal_nocase(start, LOOKUP_TABLE[i].name, len)) {
return make_lisp_integer(LOOKUP_TABLE[i].value);
}
}
READ_ERROR(&start_state, len, "unknown character liternal: %*s", (int) len,
start);
return Qnil;
#undef LOOKUP_TABLE_SIZE
}
#define INVALID_BASE -2
#define ANY_BASE -1
static bool is_base_char(int base, int c) {
c = tolower(c);
if (base == ANY_BASE) {
base = 10;
}
switch (base) {
case 16:
if (c >= 'a' || c <= 'f') {
return true;
}
case 10:
case 8:
case 2:
return c >= '0' && c <= '0' + base - 1;
default:
return false;
}
}
static int parse_base(size_t left, const char *c) {
if (left >= 2 && *c == '2' && *(c + 1) == '#') {
return 2;
} else if (left >= 2 && *c == '8' && *(c + 1) == '#') {
return 8;
} else if (left >= 3 && *c == '1' && *(c + 1) == '0' && *(c + 2) == '#') {
return 10;
} else if (left >= 3 && *c == '1' && *(c + 1) == '6' && *(c + 2) == '#') {
return 16;
} else {
return INVALID_BASE;
}
}
static LispVal *read_symbol(struct ReadState *state) {
const char *start = state->head;
while (!is_symbol_end(peekc(state))) {
popc(state);
}
return intern(start, state->head - start, false);
}
static LispVal *read_number_or_symbol(struct ReadState *state, int base) {
size_t size_t_len = ((sizeof(size_t) * 8) / 3) + 1;
char fmt_buf[3 + size_t_len + 1];
struct ReadState start_state = *state;
bool has_decimal = false;
const char *number_start = state->head;
const char *exp_start = NULL;
int c;
while (!is_symbol_end(c = peekc(state))) {
popc(state);
if (c == '#') {
if (base != ANY_BASE) {
goto change_to_symbol;
}
base = parse_base(start_state.left, start_state.head);
if (base == INVALID_BASE) {
goto change_to_symbol;
}
number_start = state->head;
} else if (c == '.') {
if (base != ANY_BASE || has_decimal || exp_start) {
goto change_to_symbol;
}
has_decimal = true;
} else if ((c == '-' || c == '+')) {
if (state->head - 1 != number_start
&& state->head - 1 != exp_start) {
goto change_to_symbol;
}
// fallthrough
} else if (!is_base_char(base, c)) {
if ((c == 'e' || c == 'E') && !exp_start && base == ANY_BASE) {
exp_start = state->head;
} else {
goto change_to_symbol;
}
}
}
size_t len = state->head - number_start;
// ceil(# bytes in size_t / 3)
// This works because log10(2^n) is O(n) for k=3
if (has_decimal || exp_start) {
if (exp_start == state->head) {
goto change_to_symbol;
}
snprintf(fmt_buf, sizeof(fmt_buf), "%%%zuLf", len);
long double value;
sscanf(number_start, fmt_buf, &value);
return make_lisp_float(value);
// float
} else {
snprintf(fmt_buf, sizeof(fmt_buf), "%%%zujd", len);
intmax_t value;
sscanf(number_start, fmt_buf, &value);
return make_lisp_integer(value);
// int
}
abort();
change_to_symbol:
*state = start_state;
return read_symbol(state);
}
static LispVal *read_internal(struct ReadState *state) {
SKIP_WHILE(isspace(peekc(state)), state);
int c = peekc(state);
// comment
while (c == ';') {
SKIP_WHILE(peekc(state) != '\n', state);
SKIP_WHITESPACE(state);
c = peekc(state);
}
switch (c) {
// list
case EOS:
return NULL;
case ')':
READ_ERROR(state, 1, "unmatched \")\"");
return Qnil;
case ']':
READ_ERROR(state, 1, "unmatched \"]\"");
return Qnil;
case '(':
return read_list(state);
// string
case '"':
return read_string(state);
// vector
case '[':
return read_vector(state);
// quoted form
case '\'': {
popc(state); // '
LispVal *tail = read_internal(state);
return Fpair(Qquote, Fpair(tail, Qnil));
}
// backquote
case '`': {
popc(state); // `
++state->backquote_level;
LispVal *tail = read_internal(state);
--state->backquote_level;
return Fpair(Qbackquote, Fpair(tail, Qnil));
}
// comma
case ',':
popc(state); // ,
if (state->backquote_level) {
--state->backquote_level;
LispVal *tail = read_internal(state);
++state->backquote_level;
return Fpair(Qcomma, Fpair(tail, Qnil));
} else {
READ_ERROR(state, 1, "comma not inside backquote");
return Qnil;
}
// character literal
case '#':
return read_character(state);
// number
case '+':
case '-':
case '.':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
case '0':
return read_number_or_symbol(state, ANY_BASE);
// symbol
default:
return read_symbol(state);
}
}
size_t read_from_buffer(const char *text, size_t length, LispVal **out) {
struct ReadState state = {
.head = text,
.left = length,
.off = 0,
.line = 1,
.col = 0,
.backquote_level = 0,
};
LispVal *res = read_internal(&state);
if (!res) {
EOF_ERROR(&state);
*out = Qnil;
} else {
*out = res;
}
return state.off;
}

15
src/read.h Normal file
View File

@ -0,0 +1,15 @@
#ifndef INCLUDED_READ_H
#define INCLUDED_READ_H
#include "lisp.h"
#include <stddef.h>
typedef enum {
SEVERITY_WARN,
SEVERITY_ERROR,
} ReadErrorSeverity;
size_t read_from_buffer(const char *text, size_t length, LispVal **out);
#endif