From eeff5e273f22aa28e81ab080e9ffdce85ac394b8 Mon Sep 17 00:00:00 2001 From: Bad Diode Date: Fri, 22 Oct 2021 09:59:31 +0200 Subject: Prepare skeleton for bytecode interpreter --- src/treewalk/darray.h | 78 ++++ src/treewalk/environment.c | 72 ++++ src/treewalk/environment.h | 27 ++ src/treewalk/errors.c | 29 ++ src/treewalk/errors.h | 38 ++ src/treewalk/gc.c | 199 ++++++++++ src/treewalk/gc.h | 46 +++ src/treewalk/hashtable.h | 191 ++++++++++ src/treewalk/lexer.c | 257 +++++++++++++ src/treewalk/lexer.h | 57 +++ src/treewalk/main.c | 288 ++++++++++++++ src/treewalk/objects.c | 141 +++++++ src/treewalk/objects.h | 75 ++++ src/treewalk/parser.c | 139 +++++++ src/treewalk/parser.h | 22 ++ src/treewalk/primitives.c | 918 +++++++++++++++++++++++++++++++++++++++++++++ src/treewalk/primitives.h | 60 +++ src/treewalk/read_line.c | 32 ++ src/treewalk/read_line.h | 10 + src/treewalk/singletons.c | 17 + src/treewalk/string_view.c | 40 ++ src/treewalk/string_view.h | 21 ++ 22 files changed, 2757 insertions(+) create mode 100644 src/treewalk/darray.h create mode 100644 src/treewalk/environment.c create mode 100644 src/treewalk/environment.h create mode 100644 src/treewalk/errors.c create mode 100644 src/treewalk/errors.h create mode 100644 src/treewalk/gc.c create mode 100644 src/treewalk/gc.h create mode 100644 src/treewalk/hashtable.h create mode 100644 src/treewalk/lexer.c create mode 100644 src/treewalk/lexer.h create mode 100755 src/treewalk/main.c create mode 100644 src/treewalk/objects.c create mode 100644 src/treewalk/objects.h create mode 100644 src/treewalk/parser.c create mode 100644 src/treewalk/parser.h create mode 100644 src/treewalk/primitives.c create mode 100644 src/treewalk/primitives.h create mode 100644 src/treewalk/read_line.c create mode 100644 src/treewalk/read_line.h create mode 100644 src/treewalk/singletons.c create mode 100644 src/treewalk/string_view.c create mode 100644 src/treewalk/string_view.h (limited to 'src/treewalk') diff --git a/src/treewalk/darray.h b/src/treewalk/darray.h new file mode 100644 index 0000000..db6234d --- /dev/null +++ b/src/treewalk/darray.h @@ -0,0 +1,78 @@ +#ifndef BDL_DARRAY_H +#define BDL_DARRAY_H + +#include + +typedef struct ArrayHeader { + size_t size; + size_t cap; +} ArrayHeader; + +// Header/Size/capacity accessors. +#define array_head(ARR) ((ArrayHeader *)((char *)(ARR) - sizeof(ArrayHeader))) +#define array_size(ARR) ((ARR) ? array_head(ARR)->size : 0) +#define array_cap(ARR) ((ARR) ? array_head(ARR)->cap : 0) + +// Initialize a dynamic array ARR with N elements. The initialization doesn't +// zero out the data, so thread carefully.. +#define array_init(ARR,N) ((ARR) = _array_reserve(N, sizeof(*(ARR)))) + +// Push a given element T to the dynamic array ARR. +#define array_push(ARR, T) \ + ((ARR) = _array_maybe_grow(ARR, sizeof(T)), \ + (ARR)[array_head(ARR)->size++] = (T)) + +// Return the last element of the array. Can be used to build stacks. +#define array_pop(ARR) (ARR)[--array_head(ARR)->size] + +// Insert N bytes from the SRC array into the ARR dynamic array. +#define array_insert(ARR, SRC, N) \ + ((ARR) = _array_insert(ARR, SRC, N, sizeof(*(ARR)))) + +// Free the memory from the original allocated position. +#define array_free(ARR) ((ARR) ? free(array_head(ARR)), (ARR) = NULL : 0) + +static inline void * +_array_reserve(size_t num_elem, size_t type_size) { + char *p = malloc(num_elem * type_size + sizeof(ArrayHeader)); + p += sizeof(ArrayHeader); + array_head(p)->size = 0; + array_head(p)->cap = num_elem; + return p; +} + +static inline void * +_array_maybe_grow(void *arr, size_t type_size) { + ArrayHeader *head = array_head(arr); + if (head->cap == head->size) { + if (head->cap == 0) { + head->cap++; + } else { + head->cap *= 2; + } + head = realloc(head, head->cap * type_size + sizeof(ArrayHeader)); + } + arr = (char *)head + sizeof(ArrayHeader); + return arr; +} + +static inline +char * _array_insert(char *arr, const char *src, size_t n_bytes, size_t type_size) { + ArrayHeader *head = array_head(arr); + size_t new_size = n_bytes + head->size; + if (new_size >= head->cap * type_size) { + if (head->cap == 0) { + head->cap = 1; + } + while (new_size >= head->cap * type_size) { + head->cap *= 2; + } + head = realloc(head, head->cap * type_size + sizeof(ArrayHeader)); + } + arr = (char *)head + sizeof(ArrayHeader); + memcpy((arr + head->size), src, n_bytes); + head->size = new_size; + return arr; +} + +#endif // BDL_DARRAY_H diff --git a/src/treewalk/environment.c b/src/treewalk/environment.c new file mode 100644 index 0000000..dd4a648 --- /dev/null +++ b/src/treewalk/environment.c @@ -0,0 +1,72 @@ +#include "environment.h" +#include "gc.h" +#include "errors.h" + +Environment * +env_create(Environment *parent) { + Environment *env = alloc_env(); + env->parent = parent; + env->marked = false; + env->table = ht_init(); + return env; +} + +void +env_add_symbol(Environment *env, Object *symbol, Object *value) { + if (symbol->type != OBJ_TYPE_SYMBOL) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_A_SYMBOL, + .line = 0, + .col = 0, + }); + return; + } + ht_insert(env->table, symbol, value); +} + +Object * +env_lookup(Environment *env, Object *symbol) { + while (env != NULL) { + Object *obj = ht_lookup(env->table, symbol); + if (obj != NULL) { + return obj; + } + env = env->parent; + } + return obj_err; +} + +Object * +env_update(Environment *env, Object *symbol, Object *value) { + while (env != NULL) { + Object *obj = ht_lookup(env->table, symbol); + if (obj != NULL) { + ht_insert(env->table, symbol, value); + return obj_nil; + } + env = env->parent; + } + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_SYMBOL_NOT_FOUND, + }); + return obj_err; +} + +void +env_add_or_update_current(Environment *env, Object *symbol, Object *value) { + ht_insert(env->table, symbol, value); +} + +Environment * +env_extend(Environment *parent, Environment *extra) { + Environment *env = parent; + HashTablePair *pairs = extra->table->pairs; + for (size_t i = 0; i < array_cap(pairs); i++) { + if (pairs[i].key != NULL) { + ht_insert(env->table, pairs[i].key, pairs[i].value); + } + } + return env; +} diff --git a/src/treewalk/environment.h b/src/treewalk/environment.h new file mode 100644 index 0000000..5ee21ad --- /dev/null +++ b/src/treewalk/environment.h @@ -0,0 +1,27 @@ +#ifndef BDL_ENVIRONMENT_H +#define BDL_ENVIRONMENT_H + +#include "objects.h" + +typedef struct Environment { + struct Environment *parent; + HashTable *table; + bool marked; +} Environment; + +Environment * env_create(Environment *parent); +void env_add_symbol(Environment *env, Object *symbol, Object *value); +Object * env_lookup(Environment *env, Object *symbol); +Object * env_update(Environment *env, Object *symbol, Object *value); +ssize_t env_index_current(Environment *env, Object *symbol); +void env_add_or_update_current(Environment *env, Object *symbol, Object *value); +Environment * env_extend(Environment *parent, Environment *extra); + +#define MAKE_ENV_VAR(ENV,STR,VAR) \ + (env_add_symbol((ENV), MAKE_SYM(STR), (VAR))) +#define MAKE_ENV_PROC(ENV,STR,FUN) \ + (env_add_symbol((ENV), MAKE_SYM(STR), make_procedure(FUN))) + +#define ENV_BUF_CAP 8 + +#endif // BDL_ENVIRONMENT_H diff --git a/src/treewalk/errors.c b/src/treewalk/errors.c new file mode 100644 index 0000000..d957cfa --- /dev/null +++ b/src/treewalk/errors.c @@ -0,0 +1,29 @@ +#include "errors.h" + +static const char* error_msgs[] = { + [ERR_UNKNOWN] = "error: something unexpected happened", + [ERR_UNMATCHED_STRING] = "error: unmatched string delimiter", + [ERR_UNBALANCED_PAREN] = "error: unbalanced parentheses", + [ERR_NOT_IMPLEMENTED] = "error: not implemented", + [ERR_EOF_REACHED] = "error: EOF reached", + [ERR_UNKNOWN_TOKEN] = "error: unknown token", + [ERR_UNKNOWN_OBJ_TYPE] = "error: can't eval unknown object type", + [ERR_NOT_A_SYMBOL] = "error: object is not a symbol", + [ERR_SYMBOL_NOT_FOUND] = "error: symbol not found", + [ERR_OBJ_NOT_CALLABLE] = "error: object is not callable", + [ERR_NOT_ENOUGH_ARGS] = "error: not enough arguments", + [ERR_TOO_MANY_ARGS] = "error: too many arguments", + [ERR_WRONG_ARG_TYPE] = "error: wrong argument type", + [ERR_DIVISION_BY_ZERO] = "error: division by zero", +}; + +static Error errors[ERR_MAX_NUMBER]; +static size_t errors_n = 0; +static bool supress_errors = false; + +void +error_push(Error error) { + if (errors_n < ERR_MAX_NUMBER) { + errors[errors_n++] = error; + } +} diff --git a/src/treewalk/errors.h b/src/treewalk/errors.h new file mode 100644 index 0000000..7916f4a --- /dev/null +++ b/src/treewalk/errors.h @@ -0,0 +1,38 @@ +#ifndef BDL_ERRORS_H +#define BDL_ERRORS_H + +typedef enum ErrorType { + ERR_TYPE_LEXER, + ERR_TYPE_PARSER, + ERR_TYPE_RUNTIME, +} ErrorType; + +typedef enum ErrorValue { + ERR_UNKNOWN = 0, + ERR_UNMATCHED_STRING, + ERR_UNBALANCED_PAREN, + ERR_NOT_IMPLEMENTED, + ERR_EOF_REACHED, + ERR_UNKNOWN_TOKEN, + ERR_UNKNOWN_OBJ_TYPE, + ERR_NOT_A_SYMBOL, + ERR_SYMBOL_NOT_FOUND, + ERR_OBJ_NOT_CALLABLE, + ERR_NOT_ENOUGH_ARGS, + ERR_TOO_MANY_ARGS, + ERR_WRONG_ARG_TYPE, + ERR_DIVISION_BY_ZERO, +} ErrorValue; + +typedef struct Error { + ErrorType type; + ErrorValue value; + size_t line; + size_t col; +} Error; + +void error_push(Error error); + +#define ERR_MAX_NUMBER 16 + +#endif // BDL_ERRORS_H diff --git a/src/treewalk/gc.c b/src/treewalk/gc.c new file mode 100644 index 0000000..358a07e --- /dev/null +++ b/src/treewalk/gc.c @@ -0,0 +1,199 @@ +#include "gc.h" + +Environment * +alloc_env(void) { + if (array_size(gc.free_envs.offsets) == 0) { + mark_and_sweep(); + if (array_size(gc.free_envs.offsets) == 0) { + fprintf(stderr, "NO MORE ENV MEMORY AVAILABLE WHERE IS YOUR GOD NOW MWAHAHA\n"); + dump_gc(); + exit(EXIT_FAILURE); + // TODO: grow heap tables. + } + } + size_t slot = gc.free_envs.offsets[gc.free_envs.position++]; + array_head(gc.free_envs.offsets)->size--; + return &gc.envs[slot]; +} + +void +push_root(Object *obj) { + array_push(gc.roots, obj); +} + +Object * +pop_root(void) { + return array_pop(gc.roots); +} + +void +push_active_env(Environment *env) { + array_push(gc.active_envs, env); +} + +Environment * +pop_active_env(void) { + return array_pop(gc.active_envs); +} + +void +gc_init(void) { + gc = (GC){0}; + + array_init(gc.objects, GC_OBJS_CAP); + array_init(gc.roots, GC_ROOTS_CAP); + array_init(gc.active_envs, GC_ACTIVE_ENVS_CAP); + array_init(gc.envs, GC_ENVS_CAP); + array_init(gc.free_objects.offsets, GC_OBJS_CAP); + array_init(gc.free_envs.offsets, GC_ENVS_CAP); + + // The free list stores the offset from the initial position for all + // available slots. + for (size_t i = 0; i < GC_OBJS_CAP; i++) { + array_push(gc.free_objects.offsets, i); + } + for (size_t i = 0; i < GC_ENVS_CAP; i++) { + array_push(gc.free_envs.offsets, i); + } +} + +void +mark_environment(Environment *env) { + if (env == NULL || env->marked) { + return; + } + env->marked = true; + HashTablePair *pairs = env->table->pairs; + for (size_t i = 0; i < array_cap(pairs); i++) { + if (pairs[i].key != NULL) { + mark_obj(pairs[i].key); + mark_obj(pairs[i].value); + } + } +} + +void +mark_obj(Object *obj) { + if (obj->marked) { + return; + } + obj->marked = true; + if (obj->type == OBJ_TYPE_PAIR) { + mark_obj(obj->car); + mark_obj(obj->cdr); + } + if (obj->type == OBJ_TYPE_LAMBDA) { + mark_obj(obj->params); + mark_obj(obj->body); + mark_environment(obj->env); + } +} + +void +mark_and_sweep(void) { + // Mark. + for (size_t i = 0; i < array_size(gc.active_envs); i++) { + mark_environment(gc.active_envs[i]); + } + for (size_t i = 0; i < array_size(gc.roots); i++) { + mark_obj(gc.roots[i]); + } + + // Reset the free list. + gc.free_objects.position = 0; + array_head(gc.free_objects.offsets)->size = 0; + gc.free_envs.position = 0; + array_head(gc.free_envs.offsets)->size = 0; + + // Sweep. + for (size_t i = 0; i < array_cap(gc.objects); i++) { + Object *obj = &gc.objects[i]; + if (!obj->marked) { + // Free heap allocated memory for this object if needed. + if (obj->type == OBJ_TYPE_SYMBOL) { + array_free(obj->symbol); + } else if (obj->type == OBJ_TYPE_STRING) { + array_free(obj->string); + } + gc.free_objects.offsets[array_head(gc.free_objects.offsets)->size++] = i; + } + obj->marked = false; + } + for (size_t i = 0; i < array_cap(gc.envs); i++) { + Environment *env = &gc.envs[i]; + if (!env->marked) { + ht_free(env->table); + gc.free_envs.offsets[array_head(gc.free_envs.offsets)->size++] = i; + } + env->marked = false; + } +} + +void +dump_gc(void) { + printf("-------------- ROOTS -------------- \n"); + for (size_t i = 0; i < array_size(gc.roots); i++) { + display(gc.roots[i]); + printf("\n"); + } + printf("--------- OBJECTS (TOP 20) -------- \n"); + for (size_t i = 0; i < 20; i++) { + printf("i: %ld -> ", i); + Object *obj = &gc.objects[i]; + display(obj); + bool is_free = false; + for (size_t j = 0; j < array_cap(gc.objects); j++) { + if (gc.free_objects.offsets[j] == i) { + is_free = true; + break; + } + } + if (is_free) { + printf(" [FREE]"); + } + printf("\n"); + } + printf("-------------- MISC --------------- \n"); + printf("gc.roots.size: %ld\n", array_size(gc.roots)); + printf("gc.roots.cap: %ld\n", array_size(gc.roots)); + printf("gc.active_envs.size: %ld\n", array_size(gc.active_envs)); + printf("gc.active_envs.cap: %ld\n", array_cap(gc.active_envs)); + printf("gc.obj_cap: %ld\n", array_cap(gc.objects)); + printf("gc.free_objects.size: %ld\n", array_size(gc.free_objects.offsets)); + printf("gc.free_objects.cap: %ld\n", array_cap(gc.free_objects.offsets)); + printf("gc.free_objects.position: %ld\n", gc.free_objects.position); + printf("array_size(gc.free_envs.offsets): %ld\n", array_size(gc.free_envs.offsets)); + printf("gc.free_envs.cap: %ld\n", array_cap(gc.free_envs.offsets)); + printf("gc.free_envs.position: %ld\n", gc.free_envs.position); + printf("gc.envs.size: %ld\n", array_size(gc.envs)); + printf("gc.envs.cap: %ld\n", array_cap(gc.envs)); +} + +Object * +alloc_object(ObjectType type) { + if (array_head(gc.free_objects.offsets)->size == 0) { + mark_and_sweep(); + if (array_head(gc.free_objects.offsets)->size == 0) { + fprintf(stderr, "NO MORE OBJ MEMORY AVAILABLE WHERE IS YOUR GOD NOW MWAHAHA\n"); + dump_gc(); + exit(EXIT_FAILURE); + // TODO: grow heap tables. + // NOTE: When growing the tables, we WILL lose the pointer + // references! Should we work with offsets all the way? That is for + // cdr and car? Should we have a utility function? All in all, we + // need to refactor the codebase first to work with pointer offsets + // rather than objects. This issue is very important, if we are in + // the middle of an operation that tries to allocate memory but we + // had saved pointers to some object, the pointer references may be + // invalidated, crashing or worse, silently returning garbage! Let's + // move on for now implementing the GC and we will revisit this part + // later. + } + } + size_t slot = gc.free_objects.offsets[gc.free_objects.position++]; + array_head(gc.free_objects.offsets)->size--; + Object *obj = &gc.objects[slot]; + obj->type = type; + obj->marked = false; + return obj; +} diff --git a/src/treewalk/gc.h b/src/treewalk/gc.h new file mode 100644 index 0000000..9ad1615 --- /dev/null +++ b/src/treewalk/gc.h @@ -0,0 +1,46 @@ +#ifndef BDL_GC_H +#define BDL_GC_H + +#include "objects.h" +#include "environment.h" + +typedef struct FreeList { + size_t *offsets; + size_t position; +} FreeList; + +typedef struct GC { + Object **roots; + Environment *envs; + Object *objects; + FreeList free_objects; + FreeList free_envs; + Environment **active_envs; +} GC; + +void gc_init(void); + +// Allocation functions for objects and environments. +Object * alloc_object(ObjectType type); +Environment * alloc_env(void); + +// Root and environment protector functions. +void push_root(Object *obj); +Object * pop_root(void); +void push_active_env(Environment *env); +Environment * pop_active_env(void); + +// Mark and sweep algorithm functions. +void mark_environment(Environment *env); +void mark_obj(Object *obj); +void mark_and_sweep(void); + +// Debugging function to print out the contentes of some GC fields. +void dump_gc(void); + +#define GC_OBJS_CAP 1024 * 1024 +#define GC_ROOTS_CAP 1024 +#define GC_ACTIVE_ENVS_CAP 2 +#define GC_ENVS_CAP 1024 * 4 + +#endif // BDL_GC_H diff --git a/src/treewalk/hashtable.h b/src/treewalk/hashtable.h new file mode 100644 index 0000000..8f210e3 --- /dev/null +++ b/src/treewalk/hashtable.h @@ -0,0 +1,191 @@ +#ifndef BDL_HASHTABLE_H +#define BDL_HASHTABLE_H + +#include "darray.h" +#include "objects.h" + +// Minimum table capacity. +#define HT_MIN_CAP 4 +#define HT_MIN_SHIFT 2 + +// Adjust the load factor threshold at which the table will grow on insertion. +#define HT_LOAD_THRESHOLD 0.8 + +typedef struct HashTablePair { + Object *key; + Object *value; +} HashTablePair; + +typedef struct HashTable { + // All available key-value pairs as a dynamic array. + HashTablePair *pairs; + + // This table expects the number of buckets to grow in powers of two. To + // speedup the default hashing, we memoize the number of bits equivalent to + // that power of 2: + // + // cap := 1024 = 2 ^ 10, shift_amount := 10 + // + uint8_t shift_amount; +} HashTable; + +// Hash a byte stream using a circular shift + XOR hash function. +static inline uint64_t +_xor_shift_hash(const char *key, size_t n) { + uint64_t hash = 0x65d9d65f6a19574f; + char *last = (char *)key + n; + while (key != last) { + hash ^= (uint64_t)*key++; + hash = (hash << 8) | (hash >> (64 - 8)); + } + return hash; +} + +// Use Fibonacci hashing to map a hash to a value in range of the table. +static inline uint64_t +_fibonacci_hash(uint64_t hash, size_t shift_amount) { + return (hash * UINT64_C(11400714819323198485)) >> (64 - shift_amount); +} + +uint64_t +ht_hash(const HashTable *table, const Object *key) { + uint64_t hash = 0; + switch (key->type) { + case OBJ_TYPE_FIXNUM: { + hash = key->fixnum; + } break; + case OBJ_TYPE_STRING: { + hash = _xor_shift_hash(key->string, array_size(key->string)); + } break; + case OBJ_TYPE_SYMBOL: { + hash = _xor_shift_hash(key->symbol, array_size(key->symbol)); + } break; + case OBJ_TYPE_BOOL: + case OBJ_TYPE_NIL: + case OBJ_TYPE_PAIR: + case OBJ_TYPE_LAMBDA: + case OBJ_TYPE_PROCEDURE: + case OBJ_TYPE_ERR: { + hash = (uintptr_t)key; + } break; + } + hash = _fibonacci_hash(hash, table->shift_amount); + return hash; +} + +static inline float +ht_load_factor(const HashTable *table) { + return (float)array_size(table->pairs) / (float)array_cap(table->pairs); +} + +HashTable * +ht_init(void) { + HashTable *table = malloc(sizeof(HashTable)); + table->pairs = NULL; + array_init(table->pairs, HT_MIN_CAP); + for (size_t i = 0; i < array_cap(table->pairs); i++) { + table->pairs[i] = (HashTablePair){NULL, NULL}; + } + table->shift_amount = HT_MIN_SHIFT; + return table; +} + +void +_ht_insert(HashTable *table, const Object *key, const Object *value) { + size_t position = ht_hash(table, key); + size_t probe_position = position; + + // Verify the key in that position is free. If not, use linear probing to + // find the next free slot. + HashTablePair *pairs = table->pairs; + while (true) { + if (pairs[probe_position].key == NULL) { + array_head(pairs)->size++; + break; + } + if (obj_eq(pairs[probe_position].key, key)) { + break; + } + if (probe_position == array_cap(pairs) - 1) { + probe_position = 0; + } else { + probe_position++; + } + } + pairs[probe_position].key = (Object *)key; + pairs[probe_position].value = (Object *)value; +} + +void +_ht_maybe_grow(HashTable *table) { + HashTablePair *pairs = table->pairs; + if (ht_load_factor(table) < HT_LOAD_THRESHOLD) { + return; + } + + // Create a new array with 2x capacity. + table->pairs = NULL; + array_init(table->pairs, array_cap(pairs) * 2); + for (size_t i = 0; i < array_cap(table->pairs); i++) { + table->pairs[i] = (HashTablePair){NULL, NULL}; + } + table->shift_amount++; + + // Hash everything in the table for the new array capacity. + for (size_t i = 0; i < array_cap(pairs); i++) { + if (pairs[i].key != NULL) { + _ht_insert(table, pairs[i].key, pairs[i].value); + } + } + + // Free the old array. + array_free(pairs); +} + +void +ht_insert(HashTable *table, const Object *key, const Object *value) { + _ht_maybe_grow(table); + _ht_insert(table, key, value); + return; +} + +Object * +ht_lookup(const HashTable *table, const Object *key) { + size_t position = ht_hash(table, key); + size_t probe_position = position; + + // Verify the key in that position is the same. If not perform linear + // probing to find it. + HashTablePair *pairs = table->pairs; + while (true) { + if (pairs[probe_position].key == NULL) { + return NULL; + } + if (obj_eq(pairs[probe_position].key, key)) { + break; + } + if (probe_position == array_cap(pairs) - 1) { + probe_position = 0; + } else { + probe_position++; + } + if (probe_position == position) { + return NULL; + } + } + return pairs[probe_position].value; +} + +void +ht_free(HashTable *table) { + if (table == NULL) { + return; + } + if (table->pairs == NULL) { + return; + } + array_free(table->pairs); + free(table); +} + +#endif // BDL_HASHTABLE_H diff --git a/src/treewalk/lexer.c b/src/treewalk/lexer.c new file mode 100644 index 0000000..38ca37c --- /dev/null +++ b/src/treewalk/lexer.c @@ -0,0 +1,257 @@ +#include "lexer.h" + +void +print_token(Token tok) { + printf("LINE: %3ld COL: %3ld ", tok.line, tok.column); + switch (tok.type) { + case TOKEN_LPAREN: { + printf("TOKEN_LPAREN"); + } break; + case TOKEN_RPAREN: { + printf("TOKEN_RPAREN"); + } break; + case TOKEN_QUOTE: { + printf("TOKEN_QUOTE"); + } break; + case TOKEN_TRUE: { + printf("TOKEN_TRUE"); + } break; + case TOKEN_FALSE: { + printf("TOKEN_FALSE"); + } break; + case TOKEN_NIL: { + printf("TOKEN_NIL"); + } break; + case TOKEN_FIXNUM: { + printf("TOKEN_FIXNUM -> "); + sv_write(&tok.value, stdout); + } break; + case TOKEN_SYMBOL: { + printf("TOKEN_SYMBOL -> "); + sv_write(&tok.value, stdout); + } break; + case TOKEN_STRING: { + printf("TOKEN_STRING -> "); + sv_write(&tok.value, stdout); + } break; + case TOKEN_EOF: { + printf("TOKEN_EOF"); + } break; + case TOKEN_UNKNOWN: { + printf("TOKEN_UNKNOWN"); + } break; + } + printf("\n"); +} + +char +scan_next(Scanner *scanner) { + char c = sv_next(&scanner->current); + if (c == '\n') { + scanner->line_number++; + scanner->col_number = 1; + } else { + scanner->col_number++; + } + scanner->offset++; + return c; +} + +char +scan_peek(const Scanner *scanner) { + return sv_peek(&scanner->current); +} + +bool +scan_has_next(const Scanner *scanner) { + return scanner->current.n != 0; +} + +void +skip_whitespace(Scanner *scanner) { + while (scan_has_next(scanner)) { + char c = scan_peek(scanner); + switch (c) { + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': { + scan_next(scanner); + } break; + default: { + return; + } break; + } + } +} + +bool +is_delimiter(char c) { + switch (c) { + case EOF: + case '\0': + case ';': + case '"': + case '\'': + case '(': + case ')': + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': { + return true; + } break; + } + return false; +} + +TokenType +find_primitive_type(const StringView value) { + bool is_fixnum = true; + for (size_t i = 0; i < value.n; i++) { + char c = value.start[i]; + if (i == 0 && c == '-' && value.n > 1) { + continue; + } + if (!(c >= '0' && c <= '9')) { + is_fixnum = false; + break; + } + } + if (is_fixnum) { + return TOKEN_FIXNUM; + } + if (sv_equal(&value, &(StringView){"true", 4})) { + return TOKEN_TRUE; + } + if (sv_equal(&value, &(StringView){"false", 5})) { + return TOKEN_FALSE; + } + return TOKEN_SYMBOL; +} + +Token * +tokenize(const StringView *sv) { + Token *tokens = NULL; + array_init(tokens, 1); + Scanner scanner = (Scanner){ + .current = *sv, + .line_number = 1, + .col_number = 1, + }; + + while (scan_has_next(&scanner)) { + skip_whitespace(&scanner); + size_t line = scanner.line_number; + size_t col = scanner.col_number; + size_t offset = scanner.offset; + char c = scan_next(&scanner); + switch (c) { + case ';': { + while ((c = scan_next(&scanner)) != '\n' && c != '\0') {} + } break; + case '"': { + char prev = c; + bool found = false; + size_t n = 0; + while (scan_has_next(&scanner)) { + c = scan_next(&scanner); + if (c == '"' && prev != '\\') { + found = true; + break; + } + prev = c; + n++; + } + if (!found) { + error_push((Error){ + .type = ERR_TYPE_LEXER, + .value = ERR_UNMATCHED_STRING, + .line = line, + .col = col, + }); + return tokens; + } + Token token = (Token){ + .value = (StringView){ + .start = &sv->start[offset + 1], + .n = n, + }, + .type = TOKEN_STRING, + .line = line, + .column = col, + }; + array_push(tokens, token); + } break; + case '\'': { + Token token = (Token){ + .type = TOKEN_QUOTE, + .line = line, + .column = col, + }; + array_push(tokens, token); + } break; + case '(': { + if (scan_peek(&scanner) == ')') { + scan_next(&scanner); + Token token = (Token){ + .type = TOKEN_NIL, + .line = line, + .column = col, + }; + array_push(tokens, token); + } else { + Token token = (Token){ + .type = TOKEN_LPAREN, + .line = line, + .column = col, + }; + array_push(tokens, token); + } + } break; + case ')': { + Token token = (Token){ + .type = TOKEN_RPAREN, + .line = line, + .column = col, + }; + array_push(tokens, token); + } break; + default: { + size_t n = 1; + while (!is_delimiter(scan_peek(&scanner))) { + scan_next(&scanner); + n++; + } + if (c == EOF || c == '\0') { + break; + } + Token token = (Token){ + .value = (StringView){ + .start = &sv->start[offset], + .n = n, + }, + .type = TOKEN_SYMBOL, + .line = line, + .column = col, + }; + token.type = find_primitive_type(token.value); + array_push(tokens, token); + } break; + } + } + + // Push EOF token. + Token token = (Token){ + .type = TOKEN_EOF, + .line = scanner.line_number, + .column = 1, + }; + array_push(tokens, token); + + return tokens; +} diff --git a/src/treewalk/lexer.h b/src/treewalk/lexer.h new file mode 100644 index 0000000..2b2789f --- /dev/null +++ b/src/treewalk/lexer.h @@ -0,0 +1,57 @@ +#ifndef BDL_LEXER_H +#define BDL_LEXER_H + +typedef enum TokenType { + TOKEN_UNKNOWN = 0, + TOKEN_LPAREN, + TOKEN_RPAREN, + TOKEN_QUOTE, + TOKEN_TRUE, + TOKEN_FALSE, + TOKEN_NIL, + TOKEN_FIXNUM, + TOKEN_SYMBOL, + TOKEN_STRING, + TOKEN_EOF, +} TokenType; + +typedef struct Token { + TokenType type; + StringView value; + size_t line; + size_t column; +} Token; + +typedef struct Scanner { + StringView current; + size_t line_number; + size_t col_number; + size_t offset; +} Scanner; + +// Print a token to standard output for debugging purposes. +void print_token(Token tok); + +// Same functionality as the ScanView pairs, but keeping track of line and +// column numbers. +char scan_next(Scanner *scanner); +char scan_peek(const Scanner *scanner); + +// Check if the current scanner still have characters left. +bool scan_has_next(const Scanner *scanner); + +// Advance the scanner until we ran out of whitespace. +void skip_whitespace(Scanner *scanner); + +// Check if a given character is a delimiter. +bool is_delimiter(char c); + +// Extract the token type from the current string. +TokenType find_primitive_type(const StringView value); + +// Generate a list of tokens from the given string. +Token * tokenize(const StringView *sv); + +#define TOK_BUF_CAP 256 + +#endif // BDL_LEXER_H diff --git a/src/treewalk/main.c b/src/treewalk/main.c new file mode 100755 index 0000000..a5888fd --- /dev/null +++ b/src/treewalk/main.c @@ -0,0 +1,288 @@ +#include +#include +#include +#include +#include +#include +#include + +#include "darray.h" +#include "hashtable.h" + +#include "singletons.c" + +#include "environment.c" +#include "errors.c" +#include "gc.c" +#include "lexer.c" +#include "objects.c" +#include "parser.c" +#include "primitives.c" +#include "read_line.c" +#include "string_view.c" + +void +init(void) { + // Initialize garbage collector. + gc_init(); + + // Initialize singletons. + obj_nil = alloc_object(OBJ_TYPE_NIL); + obj_true = alloc_object(OBJ_TYPE_BOOL); + obj_false = alloc_object(OBJ_TYPE_BOOL); + obj_err = alloc_object(OBJ_TYPE_ERR); + obj_quote = make_symbol((StringView){"quote", 5}); + proc_if = alloc_object(OBJ_TYPE_ERR); + push_root(obj_nil); + push_root(obj_true); + push_root(obj_false); + push_root(obj_err); + push_root(obj_quote); + push_root(proc_if); + + // Global environment. + global_env = env_create(NULL); + // TODO: make sure we create symbols and strings only once (interning + // strings?) + push_active_env(global_env); + + // Primitive symbols. + MAKE_ENV_VAR(global_env, "else", obj_true); + MAKE_ENV_VAR(global_env, "nil", obj_nil); + MAKE_ENV_VAR(global_env, "if", proc_if); + + // Primitive procedures. + MAKE_ENV_PROC(global_env, "eval", proc_eval); + MAKE_ENV_PROC(global_env, "quote", proc_quote); + MAKE_ENV_PROC(global_env, "car", proc_car); + MAKE_ENV_PROC(global_env, "cdr", proc_cdr); + MAKE_ENV_PROC(global_env, "cons", proc_cons); + MAKE_ENV_PROC(global_env, "list", proc_list); + MAKE_ENV_PROC(global_env, "+", proc_sum); + MAKE_ENV_PROC(global_env, "-", proc_sub); + MAKE_ENV_PROC(global_env, "*", proc_mul); + MAKE_ENV_PROC(global_env, "/", proc_div); + MAKE_ENV_PROC(global_env, "%", proc_mod); + MAKE_ENV_PROC(global_env, "print", proc_print); + MAKE_ENV_PROC(global_env, "display", proc_display); + MAKE_ENV_PROC(global_env, "newline", proc_newline); + MAKE_ENV_PROC(global_env, "boolean?", proc_is_boolean); + MAKE_ENV_PROC(global_env, "nil?", proc_is_nil); + MAKE_ENV_PROC(global_env, "symbol?", proc_is_symbol); + MAKE_ENV_PROC(global_env, "string?", proc_is_string); + MAKE_ENV_PROC(global_env, "fixnum?", proc_is_fixnum); + MAKE_ENV_PROC(global_env, "pair?", proc_is_pair); + MAKE_ENV_PROC(global_env, "procedure?", proc_is_procedure); + MAKE_ENV_PROC(global_env, "error?", proc_is_error); + MAKE_ENV_PROC(global_env, "not", proc_not); + MAKE_ENV_PROC(global_env, "and", proc_and); + MAKE_ENV_PROC(global_env, "or", proc_or); + MAKE_ENV_PROC(global_env, "cond", proc_cond); + MAKE_ENV_PROC(global_env, "<", proc_num_less_than); + MAKE_ENV_PROC(global_env, "<=", proc_num_lesseq_than); + MAKE_ENV_PROC(global_env, ">", proc_num_greater_than); + MAKE_ENV_PROC(global_env, ">=", proc_num_greatereq_than); + MAKE_ENV_PROC(global_env, "=", proc_num_equal); + MAKE_ENV_PROC(global_env, "eq?", proc_equal); + MAKE_ENV_PROC(global_env, "def", proc_define); + MAKE_ENV_PROC(global_env, "set!", proc_set); + MAKE_ENV_PROC(global_env, "lambda", proc_lambda); + MAKE_ENV_PROC(global_env, "fun", proc_fun); + + // Runtime procedures. + MAKE_ENV_PROC(global_env, "supress-errors", proc_supress_errors); +} + +void +process_source(const StringView *source) { + Token *tokens = tokenize(source); + if (errors_n != 0) { + if (tokens != NULL) { + array_free(tokens); + } + return; + } + + Visitor visitor = (Visitor){ + .tokens = tokens, + .current = 0, + }; + while (has_next_token(&visitor) && peek_token(&visitor).type != TOKEN_EOF) { + // Check the root node stack size before parsing + size_t root_stack_size = array_size(gc.roots); + Object *root = parse_tree(&visitor); + array_head(gc.roots)->size = root_stack_size; + if (root == obj_err || errors_n != 0) { + break; + } + push_root(root); + + Object *result = eval(global_env, root); + if (result != obj_nil) { + display(result); + printf("\n"); + } + pop_root(); + } + + if (tokens != NULL) { + array_free(tokens); + } +} + +#define REPL_PROMPT "bdl> " + +void +run_repl(void) { + printf("BDL REPL (Press Ctrl-D or Ctrl-C to exit)\n"); + while (true) { + printf(REPL_PROMPT); + StringView sv = read_line(); + if (sv.start == NULL) { + return; + } + process_source(&sv); + + // Check if there were any errors. + if (errors_n != 0 && !supress_errors) { + for (size_t i = 0; i < errors_n; i++) { + Error err = errors[i]; + for (size_t j = 0; j < err.col + sizeof(REPL_PROMPT) - 2; j++) { + putchar(' '); + } + printf("|\n"); + for (size_t j = 0; j < err.col + sizeof(REPL_PROMPT) - 2; j++) { + putchar(' '); + } + printf("%s\n", error_msgs[err.value]); + } + errors_n = 0; + continue; + } + } +} + +void +run_file(char *file_name) { + FILE *file = fopen(file_name, "r"); + if (!file) { + fprintf(stderr, "error: couldn't open input file: %s\n", file_name); + exit(EXIT_FAILURE); + } + + // Read entire file into memory. + fseek(file, 0, SEEK_END); + size_t file_size = ftell(file); + fseek(file, 0, SEEK_SET); + + char *source = malloc(file_size + 1); + fread(source, 1, file_size, file); + source[file_size] = 0; + + StringView sv = (StringView){ + .start = source, + .n = file_size, + }; + + process_source(&sv); + + // Check if there were any errors. + if (errors_n != 0 && !supress_errors) { + for (size_t i = 0; i < errors_n; i++) { + Error err = errors[i]; + fprintf(stderr, "%s", file_name); + if (err.line != 0) { + fprintf(stderr, ":%ld:%ld", err.line, err.col); + } + fprintf(stderr, ": %s\n", error_msgs[err.value]); + } + errors_n = 0; + } + + free(source); + fclose(file); +} + +#define STDIN_BUF_CAP 16 + +void +run_stdin(void) { + size_t buf_size = 0; + char *source = NULL; + array_init(source, STDIN_BUF_CAP); + + char c; + while ((c = getchar()) != EOF) { + array_push(source, c); + buf_size++; + } + + StringView sv = (StringView){ + .start = source, + .n = buf_size, + }; + + process_source(&sv); + + // Check if there were any errors. + if (errors_n != 0 && !supress_errors) { + for (size_t i = 0; i < errors_n; i++) { + Error err = errors[i]; + fprintf(stderr, "stdin"); + if (err.line != 0) { + fprintf(stderr, ":%ld:%ld", err.line, err.col); + } + fprintf(stderr, ": %s\n", error_msgs[err.value]); + } + errors_n = 0; + } + + array_free(source); +} + +#ifndef BIN_NAME +#define BIN_NAME "bdl" +#endif + +void +print_usage(void) { + printf("Usage: %s [options] \n", BIN_NAME); + printf("\n"); + printf("\t-i\tInteractive mode (REPL).\n"); + printf("\n"); +} + +int +main(int argc, char *argv[]) { + init(); + + int option; + while ((option = getopt(argc, argv, "i")) != -1) { + switch (option) { + case 'i': { + // Interactive mode. + run_repl(); + return EXIT_SUCCESS; + } break; + default: { + print_usage(); + return EXIT_FAILURE; + } break; + } + } + + // Run from stdin. + if (optind == argc) { + run_stdin(); + return EXIT_SUCCESS; + } + + // Run from file. + while (optind < argc) { + char *file_name = argv[optind]; + run_file(file_name); + optind++; + } + + return EXIT_SUCCESS; +} diff --git a/src/treewalk/objects.c b/src/treewalk/objects.c new file mode 100644 index 0000000..c71bc40 --- /dev/null +++ b/src/treewalk/objects.c @@ -0,0 +1,141 @@ +#include "gc.h" +#include "objects.h" + +// +// Constructors. +// + +Object * +make_fixnum(ssize_t num) { + Object *obj = alloc_object(OBJ_TYPE_FIXNUM); + obj->fixnum = num; + return obj; +} + +Object * +make_procedure(Object *(*proc)(struct Environment *, struct Object *args)) { + Object *obj = alloc_object(OBJ_TYPE_PROCEDURE); + obj->proc = proc; + return obj; +} + +Object * +make_pair(Object *car, Object *cdr) { + Object *obj = alloc_object(OBJ_TYPE_PAIR); + obj->car = car; + obj->cdr = cdr; + return obj; +} + +Object * +make_symbol(StringView sv) { + Object *obj = alloc_object(OBJ_TYPE_SYMBOL); + obj->symbol = NULL; + array_init(obj->symbol, sv.n); + array_insert(obj->symbol, sv.start, sv.n); + return obj; +} + +Object * +make_string(void) { + Object *obj = alloc_object(OBJ_TYPE_STRING); + obj->string = NULL; + array_init(obj->string, 0); + return obj; +} + +void +append_string(Object *obj, const StringView sv) { + if (sv.n == 0) { + return; + } + array_insert(obj->string, sv.start, sv.n); +} + +void +display_pair(Object *root) { + display(root->car); + if (root->cdr->type == OBJ_TYPE_PAIR) { + printf(" "); + display_pair(root->cdr); + } else if (root->cdr == obj_nil) { + return; + } else { + printf(" . "); + display(root->cdr); + } +} + +void +display(Object *root) { + switch (root->type) { + case OBJ_TYPE_FIXNUM: { + printf("%zd", root->fixnum); + } break; + case OBJ_TYPE_BOOL: { + if (root == obj_true) { + printf("true"); + } else { + printf("false"); + } + } break; + case OBJ_TYPE_NIL: { + printf("()"); + } break; + case OBJ_TYPE_STRING: { + printf("\"%.*s\"", (int)array_size(root->string), root->string); + } break; + case OBJ_TYPE_SYMBOL: { + printf(":%.*s", (int)array_size(root->symbol), root->symbol); + } break; + case OBJ_TYPE_PAIR: { + printf("("); + display_pair(root); + printf(")"); + } break; + case OBJ_TYPE_LAMBDA: + case OBJ_TYPE_PROCEDURE: { + printf("#{procedure}"); + } break; + case OBJ_TYPE_ERR: { + printf("#{error}"); + } break; + } + return; +} + +bool +obj_eq(const Object *a, const Object* b) { + if (a->type != b->type) { + return false; + } + switch (a->type) { + case OBJ_TYPE_FIXNUM: { + return a->fixnum == b->fixnum; + } break; + case OBJ_TYPE_STRING: { + if (array_size(a->string) != array_size(b->string)) { + return false; + } + for (size_t i = 0; i < array_size(a->string); i++) { + if (a->string[i] != b->string[i]) { + return false; + } + } + } break; + case OBJ_TYPE_SYMBOL: { + if (array_size(a->symbol) != array_size(b->symbol)) { + return false; + } + for (size_t i = 0; i < array_size(a->symbol); i++) { + if (a->symbol[i] != b->symbol[i]) { + return false; + } + } + } break; + default: { + return a == b; + } break; + } + return true; +} diff --git a/src/treewalk/objects.h b/src/treewalk/objects.h new file mode 100644 index 0000000..ed623eb --- /dev/null +++ b/src/treewalk/objects.h @@ -0,0 +1,75 @@ +#ifndef BDL_OBJECTS_H +#define BDL_OBJECTS_H + +#include "string_view.h" + +typedef enum ObjectType { + OBJ_TYPE_FIXNUM, + OBJ_TYPE_BOOL, + OBJ_TYPE_NIL, + OBJ_TYPE_SYMBOL, + OBJ_TYPE_STRING, + OBJ_TYPE_PAIR, + OBJ_TYPE_PROCEDURE, + OBJ_TYPE_LAMBDA, + OBJ_TYPE_ERR, +} ObjectType; + +struct Environment; + +typedef struct Object { + ObjectType type; + bool marked; + union { + // OBJ_TYPE_FIXNUM + ssize_t fixnum; + + // OBJ_TYPE_STRING + struct { + char *string; + }; + + // OBJ_TYPE_PAIR + struct { + struct Object *car; + struct Object *cdr; + }; + + // OBJ_TYPE_SYMBOL + struct { + char *symbol; + }; + + // OBJ_TYPE_PROCEDURE + struct Object *(*proc)(struct Environment *env, struct Object *args); + + // OBJ_TYPE_LAMBDA + struct { + struct Object *params; + struct Object *body; + struct Environment *env; + }; + }; +} Object; + +// Object constructors. +Object * make_fixnum(ssize_t num); +Object * make_procedure(Object *(*proc)(struct Environment *, Object *args)); +Object * make_pair(Object *car, Object *cdr); +Object * make_symbol(StringView sv); +Object * make_string(void); +void append_string(Object *obj, const StringView sv); + +// Object representation. +void display(Object *root); +void display_pair(Object *root); + +// Object comparison. +bool obj_eq(const Object *a, const Object* b); + +// Utility macros. +#define DEBUG_OBJ(MSG,OBJ) printf((MSG)); display(OBJ); printf("\n"); +#define PRINT_OBJ(OBJ) display(OBJ); printf("\n"); +#define MAKE_SYM(STR) make_symbol((StringView){(STR), sizeof(STR) - 1}) + +#endif // BDL_OBJECTS_H diff --git a/src/treewalk/parser.c b/src/treewalk/parser.c new file mode 100644 index 0000000..a2f0f71 --- /dev/null +++ b/src/treewalk/parser.c @@ -0,0 +1,139 @@ +#include "parser.h" + +Token +peek_token(const Visitor *visitor) { + return visitor->tokens[visitor->current]; +} + +Token +next_token(Visitor *visitor) { + return visitor->tokens[visitor->current++]; +} + +bool +has_next_token(const Visitor *visitor) { + return visitor->current < array_size(visitor->tokens); +} + +Object * +parse_fixnum(Token tok) { + ssize_t num = 0; + int sign = 1; + for (size_t i = 0; i < tok.value.n; i++) { + char c = tok.value.start[i]; + if (c == '-') { + sign = -1; + continue; + } + num = num * 10 + (c - '0'); + } + + Object *obj = make_fixnum(num * sign); + push_root(obj); + return obj; +} + +Object * +parse_list(Visitor *vs) { + Token tok = peek_token(vs); + if (tok.type == TOKEN_EOF) { + return obj_err; + } + Object *root = make_pair(obj_nil, obj_nil); + push_root(root); + Object *next_obj = parse_tree(vs); + if (next_obj == obj_err) { + return obj_err; + } + root->car = next_obj; + Object *list = root; + while (has_next_token(vs)) { + Token tok = peek_token(vs); + if (tok.type == TOKEN_RPAREN) { + next_token(vs); + break; + } + if (tok.type == TOKEN_EOF) { + return obj_err; + } + next_obj = parse_tree(vs); + if (next_obj == obj_err) { + return obj_err; + } + list->cdr = make_pair(next_obj, obj_nil); + list = list->cdr; + } + return root; +} + +Object * +parse_tree(Visitor *vs) { + Token tok = next_token(vs); + switch (tok.type) { + case TOKEN_FIXNUM: { + return parse_fixnum(tok); + } break; + case TOKEN_TRUE: { + return obj_true; + } break; + case TOKEN_FALSE: { + return obj_false; + } break; + case TOKEN_RPAREN: { + error_push((Error){ + .type = ERR_TYPE_PARSER, + .value = ERR_UNBALANCED_PAREN, + .line = tok.line, + .col = tok.column, + }); + return obj_err; + } break; + case TOKEN_QUOTE: { + Object *base = make_pair(obj_quote, obj_nil); + base->cdr = make_pair(obj_nil, obj_nil); + push_root(base); + Object *next_obj = parse_tree(vs); + if (next_obj == obj_err) { + return obj_err; + } + base->cdr->car = next_obj; + return base; + } break; + case TOKEN_LPAREN: { + Object *obj = parse_list(vs); + if (obj == obj_err) { + error_push((Error){ + .type = ERR_TYPE_PARSER, + .value = ERR_UNBALANCED_PAREN, + .line = tok.line, + .col = tok.column, + }); + } + return obj; + } break; + case TOKEN_STRING: { + Object *obj = make_string(); + push_root(obj); + append_string(obj, tok.value); + return obj; + } break; + case TOKEN_SYMBOL: { + Object *obj = make_symbol(tok.value); + push_root(obj); + return obj; + } break; + case TOKEN_NIL: { + return obj_nil; + } break; + default: { + break; + } break; + } + error_push((Error){ + .type = ERR_TYPE_PARSER, + .value = ERR_EOF_REACHED, + .line = tok.line, + .col = tok.column, + }); + return obj_err; +} diff --git a/src/treewalk/parser.h b/src/treewalk/parser.h new file mode 100644 index 0000000..3834c75 --- /dev/null +++ b/src/treewalk/parser.h @@ -0,0 +1,22 @@ +#ifndef BDL_PARSER_H +#define BDL_PARSER_H + +typedef struct Visitor { + Token *tokens; + size_t current; +} Visitor; + +// Mimics the functionality in the Scanner functions, but for entire tokens. +Token next_token(Visitor *visitor); +Token peek_token(const Visitor *visitor); +bool has_next_token(const Visitor *visitor); + +// Parse a token into a fixnum object. +Object * parse_fixnum(Token tok); + +// Recursive descent parser. If an object is not a list the parsing is handled +// by the parse_tree function. +Object * parse_list(Visitor *vs); +Object * parse_tree(Visitor *vs); + +#endif // BDL_PARSER_H diff --git a/src/treewalk/primitives.c b/src/treewalk/primitives.c new file mode 100644 index 0000000..8b0d407 --- /dev/null +++ b/src/treewalk/primitives.c @@ -0,0 +1,918 @@ +#include "primitives.h" + +Object * +eval(Environment *env, Object *root) { + Object* lambda = NULL; + Object* args = NULL; + Object* ret = NULL; + bool recursion_active = false; +eval_start: + switch (root->type) { + case OBJ_TYPE_ERR: + case OBJ_TYPE_PROCEDURE: + case OBJ_TYPE_LAMBDA: + case OBJ_TYPE_FIXNUM: + case OBJ_TYPE_BOOL: + case OBJ_TYPE_NIL: + case OBJ_TYPE_STRING: { + ret = root; + goto eval_success; + } break; + case OBJ_TYPE_SYMBOL: { + Object *val = env_lookup(env, root); + if (val == obj_err) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_SYMBOL_NOT_FOUND, + }); + return obj_err; + } + ret = val; + goto eval_success; + } break; + case OBJ_TYPE_PAIR: { + if (root->car->type == OBJ_TYPE_SYMBOL) { + Object *val = env_lookup(env, root->car); + if (val == obj_err) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_SYMBOL_NOT_FOUND, + }); + return obj_err; + } + + // Primitive `if` procedure with TCO. + if (val == proc_if) { + Object *obj = root->cdr; + if (obj == obj_nil || obj->cdr == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = obj->car; + Object *cdr = obj->cdr; + Object *condition = eval(env, car); + if (condition == obj_err) { + return obj_err; + } + if (condition == obj_true) { + root = cdr->car; + } else if (cdr->cdr != obj_nil) { + root = cdr->cdr->car; + } else { + return obj_nil; + } + goto eval_start; + } + + if (val->type == OBJ_TYPE_PROCEDURE) { + ret = val->proc(env, root->cdr); + goto eval_success; + } + if (val->type == OBJ_TYPE_LAMBDA) { + lambda = val; + goto eval_lambda; + } + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_OBJ_NOT_CALLABLE, + }); + return obj_err; + } + lambda = eval(env, root->car); + if (lambda == obj_err) { + return obj_err; + } + if (lambda->type != OBJ_TYPE_LAMBDA) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_OBJ_NOT_CALLABLE, + }); + return obj_err; + } + +eval_lambda: + args = root->cdr; + Object *params = lambda->params; + if (!recursion_active) { + recursion_active = true; + // Protect current stack. + Environment *tmp = env_create(lambda->env); + push_active_env(tmp); + // Extend environment. + env = env_extend(tmp, env); + } + + // Create temporary environment to store bindings. + Environment *tmp = env_create(env); + push_active_env(tmp); + + // Evaluate arguments in temporary environment. + while (params != obj_nil) { + if (args == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + if (args->car == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *symbol = params->car; + Object *value = eval(env, args->car); + if (value == obj_err) { + return obj_err; + } + env_add_or_update_current(tmp, symbol, value); + args = args->cdr; + params = params->cdr; + } + if (args != obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_TOO_MANY_ARGS, + }); + return obj_err; + } + + // Copy temporary environment values to closure environment. + args = root->cdr; + params = lambda->params; + while (params != obj_nil) { + Object *symbol = params->car; + Object *value = env_lookup(tmp, symbol); + env_add_or_update_current(env, symbol, value); + args = args->cdr; + params = params->cdr; + } + + // Release the temporary environment protection. + pop_active_env(); + + // Run the body of the function. + root = lambda->body; + while (root->cdr != obj_nil) { + if (eval(env, root->car) == obj_err) { + return obj_err; + }; + root = root->cdr; + } + root = root->car; + goto eval_start; + } break; + } + + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_UNKNOWN_OBJ_TYPE, + }); + return obj_err; + +eval_success: + if (recursion_active) { + // Remove stack protector. + pop_active_env(); + } + return ret; +} + +Object * +proc_quote(Environment *env, Object *obj) { + (void)env; + return obj->car; +} + +static inline Object * +extract_car_with_type(Environment *env, Object *obj, ObjectType expected_type) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != expected_type) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + return car; +} + +// +// Arithmetic procedures. +// + +Object * +proc_sum(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + tot += car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +Object * +proc_sub(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + tot -= car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +Object * +proc_mul(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + tot *= car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +Object * +proc_div(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + if (car->fixnum == 0) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_DIVISION_BY_ZERO, + }); + return obj_err; + } + tot /= car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +Object * +proc_mod(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + if (car->fixnum == 0) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_DIVISION_BY_ZERO, + }); + return obj_err; + } + tot %= car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +// +// Display/Evaluation procedues. +// + +Object * +proc_display(Environment *env, Object *obj) { + display(eval(env, obj->car)); + return obj_nil; +} + +Object * +proc_print(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_STRING); + StringView scanner = (StringView) { + .start = car->string, + .n = array_size(car->string), + }; + while (scanner.n != 0) { + char c = sv_next(&scanner); + if (c == '\\' && sv_peek(&scanner) == 'n') { + putchar('\n'); + sv_next(&scanner); + continue; + } + if (c == '\\' && sv_peek(&scanner) == '"') { + putchar('"'); + sv_next(&scanner); + continue; + } + putchar(c); + } + return obj_nil; +} + +Object * +proc_newline(Environment *env, Object *obj) { + printf("\n"); + (void)env; + (void)obj; + return obj_nil; +} + +// +// Type info procedures. +// + +Object * +proc_is_boolean(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return (obj == obj_true || obj == obj_false) ? obj_true : obj_false; +} + +Object * +proc_is_nil(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj == obj_nil ? obj_true : obj_false; +} + +Object * +proc_is_symbol(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_SYMBOL ? obj_true : obj_false; +} + +Object * +proc_is_string(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_STRING ? obj_true : obj_false; +} + +Object * +proc_is_fixnum(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_FIXNUM ? obj_true : obj_false; +} + +Object * +proc_is_pair(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_PAIR ? obj_true : obj_false; +} + +Object * +proc_is_procedure(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_PROCEDURE ? obj_true : obj_false; +} + +Object * +proc_is_error(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_true; + } + return obj_false; +} + +// +// Boolean/conditional procedures. +// + +Object * +proc_not(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj == obj_false ? obj_true : obj_false; +} + +Object * +proc_and(Environment *env, Object *obj) { + while (obj != obj_nil) { + if (proc_not(env, obj) == obj_true) { + return obj_false; + } + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_or(Environment *env, Object *obj) { + while (obj != obj_nil) { + if (proc_not(env, obj) == obj_false) { + return obj_true; + } + obj = obj->cdr; + } + return obj_false; +} + +Object * +proc_cond(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + while (obj != obj_nil) { + Object *clause = obj->car; + if (clause->type != OBJ_TYPE_PAIR || clause->cdr == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + Object *test = clause->car; + Object *value = clause->cdr->car; + Object *result = eval(env, test); + if (result == obj_err) { + return obj_err; + } + if (result == obj_true) { + return eval(env, value); + } + obj = obj->cdr; + } + return obj_nil; +} + +Object * +proc_num_less_than(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + if (prev >= car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_num_greater_than(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + if (prev <= car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_num_lesseq_than(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + if (prev > car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_num_greatereq_than(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + if (prev < car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_num_equal(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); + if (prev != car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +// +// List operation procedures. +// + +Object * +proc_car(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + if (obj->type != OBJ_TYPE_PAIR) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + return obj->car; +} + +Object * +proc_cdr(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + if (obj->type != OBJ_TYPE_PAIR) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + return obj->cdr; +} + +Object * +proc_cons(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *head = make_pair(obj_nil, obj_nil); + push_root(head); + head->car = eval(env, obj->car); + if (head->car == obj_err) { + pop_root(); + return obj_err; + } + head->cdr = eval(env, obj->cdr->car); + if (head->cdr == obj_err) { + pop_root(); + return obj_err; + } + pop_root(); + return head; +} + +Object * +proc_list(Environment *env, Object *obj) { + if (obj == obj_nil) { + return obj_nil; + } + + Object *head = make_pair(obj_nil, obj_nil); + push_root(head); + Object *tmp = eval(env, obj->car); + if (tmp == obj_err) { + pop_root(); + return obj_err; + } + head->car = tmp; + Object *curr = head; + obj = obj->cdr; + while (obj != obj_nil) { + tmp = eval(env, obj->car); + if (tmp == obj_err) { + pop_root(); + return obj_err; + } + curr->cdr = make_pair(tmp, obj_nil); + curr = curr->cdr; + obj = obj->cdr; + } + pop_root(); + return head; +} + +// +// Polymorphic procedures. +// + +Object * +proc_equal(Environment *env, Object *obj) { + if (obj == obj_nil || obj->cdr == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *a = eval(env, obj->car); + if (a == obj_err) { + return obj_err; + } + Object *b = eval(env, obj->cdr->car); + if (b == obj_err) { + return obj_err; + } + return obj_eq(a, b) ? obj_true : obj_false; +} + +// +// Variables and declarations. +// + +Object * +proc_define(Environment *env, Object *obj) { + if (obj == obj_nil || obj->cdr == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + + Object *symbol = obj->car; + if (symbol->type != OBJ_TYPE_SYMBOL) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + Object *value = eval(env, obj->cdr->car); + if (value == obj_err) { + return obj_err; + } + + env_add_or_update_current(env, symbol, value); + return obj_nil; +} + +Object * +proc_set(Environment *env, Object *obj) { + if (obj == obj_nil || obj->cdr == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + + Object *symbol = obj->car; + if (symbol->type != OBJ_TYPE_SYMBOL) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + Object *value = eval(env, obj->cdr->car); + if (value == obj_err) { + return obj_err; + } + + return env_update(env, symbol, value); +} + +Object * +proc_lambda(Environment *env, Object *obj) { + if (obj == obj_nil || obj->cdr == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *params = obj->car; + if (params != obj_nil && params->type != OBJ_TYPE_PAIR) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + Object *body = obj->cdr; + Object *fun = alloc_object(OBJ_TYPE_LAMBDA); + fun->params = params; + fun->body = body; + fun->env = env; + return fun; +} + +Object * +proc_fun(Environment *env, Object *obj) { + if (obj == obj_nil || obj->cdr == obj_nil || obj->cdr->cdr == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + + Object *name = obj->car; + if (name->type != OBJ_TYPE_SYMBOL) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + Object *params = obj->cdr->car; + if (params != obj_nil && params->type != OBJ_TYPE_PAIR) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + Object *body = obj->cdr->cdr; + Object *fun = alloc_object(OBJ_TYPE_LAMBDA); + fun->params = params; + fun->body = body; + fun->env = env; + env_add_or_update_current(env, name, fun); + return obj_nil; +} + +// +// Evaluation. +// + +Object * +proc_eval(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + return eval(env, eval(env, obj->car)); +} + +// +// Runtime configuration options. +// + +Object * +proc_supress_errors(Environment *env, Object *obj) { + Object *car = extract_car_with_type(env, obj, OBJ_TYPE_BOOL); + if (car == obj_err) { + return obj_err; + } + + if (car == obj_true) { + supress_errors = true; + } else if (car == obj_false) { + supress_errors = false; + } + return obj_nil; +} + +// TODO: map +// TODO: apply +// TODO: filter + +// TODO: fixnum left/right shift, mask, invert +// TODO: add primitives for type transforms: string->symbol, symbol->string, etc +// TODO: implement support for semi-quotes +// TODO: LAMBDA +// TODO: let diff --git a/src/treewalk/primitives.h b/src/treewalk/primitives.h new file mode 100644 index 0000000..f874b17 --- /dev/null +++ b/src/treewalk/primitives.h @@ -0,0 +1,60 @@ +#ifndef BDL_PRIMITIVES_H +#define BDL_PRIMITIVES_H + +// Function evaluation. +Object * eval(Environment *env, Object *root); + +// Evaluation functions. +Object * proc_quote(Environment *env, Object *obj); +Object * proc_eval(Environment *env, Object *obj); + +// Arithmetic. +Object * proc_sum(Environment *env, Object *obj); +Object * proc_sub(Environment *env, Object *obj); +Object * proc_mul(Environment *env, Object *obj); +Object * proc_div(Environment *env, Object *obj); +Object * proc_mod(Environment *env, Object *obj); + +// Printing. +Object * proc_display(Environment *env, Object *obj); +Object * proc_print(Environment *env, Object *obj); +Object * proc_newline(Environment *env, Object *obj); + +// Type checking. +Object * proc_is_boolean(Environment *env, Object *obj); +Object * proc_is_nil(Environment *env, Object *obj); +Object * proc_is_symbol(Environment *env, Object *obj); +Object * proc_is_string(Environment *env, Object *obj); +Object * proc_is_fixnum(Environment *env, Object *obj); +Object * proc_is_pair(Environment *env, Object *obj); +Object * proc_is_procedure(Environment *env, Object *obj); +Object * proc_is_error(Environment *env, Object *obj); + +// Logical operations. +Object * proc_not(Environment *env, Object *obj); +Object * proc_and(Environment *env, Object *obj); +Object * proc_or(Environment *env, Object *obj); +Object * proc_cond(Environment *env, Object *obj); +Object * proc_num_less_than(Environment *env, Object *obj); +Object * proc_num_greater_than(Environment *env, Object *obj); +Object * proc_num_lesseq_than(Environment *env, Object *obj); +Object * proc_num_greatereq_than(Environment *env, Object *obj); +Object * proc_num_equal(Environment *env, Object *obj); +Object * proc_equal(Environment *env, Object *obj); + +// List operations. +Object * proc_car(Environment *env, Object *obj); +Object * proc_cdr(Environment *env, Object *obj); +Object * proc_cons(Environment *env, Object *obj); +Object * proc_list(Environment *env, Object *obj); + +// Environment/variable manipulation. +Object * proc_define(Environment *env, Object *obj); +Object * proc_set(Environment *env, Object *obj); +Object * proc_lambda(Environment *env, Object *obj); +Object * proc_fun(Environment *env, Object *obj); + +// Runtinme configuration. +Object * proc_supress_errors(Environment *env, Object *obj); + +#endif // BDL_PRIMITIVES_H diff --git a/src/treewalk/read_line.c b/src/treewalk/read_line.c new file mode 100644 index 0000000..03146ad --- /dev/null +++ b/src/treewalk/read_line.c @@ -0,0 +1,32 @@ +#include "read_line.h" + +static char readline_buf[RL_BUF_SIZE]; + +StringView +read_line(void) { + // Clear buffer. + for (size_t i = 0; i < RL_BUF_SIZE; i++) { + readline_buf[i] = 0; + } + + // Barebones readline implementation. + size_t n = 0; + char c; + while ((c = getchar()) != '\n') { + if (c == '\b') { + readline_buf[n] = '\0'; + n--; + } else if (c == EOF || c == '\0') { + return (StringView){ .start = NULL, .n = 0 }; + } else if ((c >= ' ' && c <= '~') && n < RL_BUF_SIZE) { + readline_buf[n] = c; + n++; + } + } + + StringView sv = (StringView){ + .start = (char *)&readline_buf, + .n = n, + }; + return sv; +} diff --git a/src/treewalk/read_line.h b/src/treewalk/read_line.h new file mode 100644 index 0000000..160bce0 --- /dev/null +++ b/src/treewalk/read_line.h @@ -0,0 +1,10 @@ +#ifndef BDL_READ_LINE_H +#define BDL_READ_LINE_H + +#include "string_view.h" + +StringView read_line(void); + +#define RL_BUF_SIZE 1024 + +#endif // BDL_READ_LINE_H diff --git a/src/treewalk/singletons.c b/src/treewalk/singletons.c new file mode 100644 index 0000000..eb9c397 --- /dev/null +++ b/src/treewalk/singletons.c @@ -0,0 +1,17 @@ +#include "environment.h" +#include "gc.h" +#include "objects.h" + +// Global garbage collector singleton. +static GC gc; + +// Special singleton Objects. +static Object *obj_nil; +static Object *obj_true; +static Object *obj_false; +static Object *obj_err; +static Object *obj_quote; +static Object *proc_if; + +// Global environment. +static Environment *global_env; diff --git a/src/treewalk/string_view.c b/src/treewalk/string_view.c new file mode 100644 index 0000000..39fabe9 --- /dev/null +++ b/src/treewalk/string_view.c @@ -0,0 +1,40 @@ +#include "string_view.h" + +char +sv_next(StringView *sv) { + if (sv->n == 0) { + return '\0'; + } + char c = sv->start[0]; + sv->start++; + sv->n--; + return c; +} + +char +sv_peek(const StringView *sv) { + if (sv->n == 0) { + return '\0'; + } + return sv->start[0]; +} + +bool +sv_equal(const StringView *a, const StringView *b) { + if (a->n != b->n) { + return false; + } + for (size_t i = 0; i < a->n; i++) { + if (a->start[i] != b->start[i]) { + return false; + } + } + return true; +} + +void +sv_write(const StringView *sv, FILE *file) { + for (size_t i = 0; i < sv->n; i++) { + putc(sv->start[i], file); + } +} diff --git a/src/treewalk/string_view.h b/src/treewalk/string_view.h new file mode 100644 index 0000000..42273ab --- /dev/null +++ b/src/treewalk/string_view.h @@ -0,0 +1,21 @@ +#ifndef BDL_STRINGVIEW_H +#define BDL_STRINGVIEW_H + +typedef struct StringView { + char *start; + size_t n; +} StringView; + +// Consume a character in the stream. +char sv_next(StringView *sv); + +// Check what is the current character in the stream. +char sv_peek(const StringView *sv); + +// Compare if the arguments are the same. +bool sv_equal(const StringView *a, const StringView *b); + +// Write a character to the given output stream. +void sv_write(const StringView *sv, FILE *file); + +#endif // BDL_STRINGVIEW_H -- cgit v1.2.1