aboutsummaryrefslogtreecommitdiffstats
path: root/src/treewalk
diff options
context:
space:
mode:
Diffstat (limited to 'src/treewalk')
-rw-r--r--src/treewalk/darray.h78
-rw-r--r--src/treewalk/environment.c72
-rw-r--r--src/treewalk/environment.h27
-rw-r--r--src/treewalk/errors.c29
-rw-r--r--src/treewalk/errors.h38
-rw-r--r--src/treewalk/gc.c199
-rw-r--r--src/treewalk/gc.h46
-rw-r--r--src/treewalk/hashtable.h191
-rw-r--r--src/treewalk/lexer.c257
-rw-r--r--src/treewalk/lexer.h57
-rwxr-xr-xsrc/treewalk/main.c288
-rw-r--r--src/treewalk/objects.c141
-rw-r--r--src/treewalk/objects.h75
-rw-r--r--src/treewalk/parser.c139
-rw-r--r--src/treewalk/parser.h22
-rw-r--r--src/treewalk/primitives.c918
-rw-r--r--src/treewalk/primitives.h60
-rw-r--r--src/treewalk/read_line.c32
-rw-r--r--src/treewalk/read_line.h10
-rw-r--r--src/treewalk/singletons.c17
-rw-r--r--src/treewalk/string_view.c40
-rw-r--r--src/treewalk/string_view.h21
22 files changed, 0 insertions, 2757 deletions
diff --git a/src/treewalk/darray.h b/src/treewalk/darray.h
deleted file mode 100644
index db6234d..0000000
--- a/src/treewalk/darray.h
+++ /dev/null
@@ -1,78 +0,0 @@
1#ifndef BDL_DARRAY_H
2#define BDL_DARRAY_H
3
4#include <string.h>
5
6typedef struct ArrayHeader {
7 size_t size;
8 size_t cap;
9} ArrayHeader;
10
11// Header/Size/capacity accessors.
12#define array_head(ARR) ((ArrayHeader *)((char *)(ARR) - sizeof(ArrayHeader)))
13#define array_size(ARR) ((ARR) ? array_head(ARR)->size : 0)
14#define array_cap(ARR) ((ARR) ? array_head(ARR)->cap : 0)
15
16// Initialize a dynamic array ARR with N elements. The initialization doesn't
17// zero out the data, so thread carefully..
18#define array_init(ARR,N) ((ARR) = _array_reserve(N, sizeof(*(ARR))))
19
20// Push a given element T to the dynamic array ARR.
21#define array_push(ARR, T) \
22 ((ARR) = _array_maybe_grow(ARR, sizeof(T)), \
23 (ARR)[array_head(ARR)->size++] = (T))
24
25// Return the last element of the array. Can be used to build stacks.
26#define array_pop(ARR) (ARR)[--array_head(ARR)->size]
27
28// Insert N bytes from the SRC array into the ARR dynamic array.
29#define array_insert(ARR, SRC, N) \
30 ((ARR) = _array_insert(ARR, SRC, N, sizeof(*(ARR))))
31
32// Free the memory from the original allocated position.
33#define array_free(ARR) ((ARR) ? free(array_head(ARR)), (ARR) = NULL : 0)
34
35static inline void *
36_array_reserve(size_t num_elem, size_t type_size) {
37 char *p = malloc(num_elem * type_size + sizeof(ArrayHeader));
38 p += sizeof(ArrayHeader);
39 array_head(p)->size = 0;
40 array_head(p)->cap = num_elem;
41 return p;
42}
43
44static inline void *
45_array_maybe_grow(void *arr, size_t type_size) {
46 ArrayHeader *head = array_head(arr);
47 if (head->cap == head->size) {
48 if (head->cap == 0) {
49 head->cap++;
50 } else {
51 head->cap *= 2;
52 }
53 head = realloc(head, head->cap * type_size + sizeof(ArrayHeader));
54 }
55 arr = (char *)head + sizeof(ArrayHeader);
56 return arr;
57}
58
59static inline
60char * _array_insert(char *arr, const char *src, size_t n_bytes, size_t type_size) {
61 ArrayHeader *head = array_head(arr);
62 size_t new_size = n_bytes + head->size;
63 if (new_size >= head->cap * type_size) {
64 if (head->cap == 0) {
65 head->cap = 1;
66 }
67 while (new_size >= head->cap * type_size) {
68 head->cap *= 2;
69 }
70 head = realloc(head, head->cap * type_size + sizeof(ArrayHeader));
71 }
72 arr = (char *)head + sizeof(ArrayHeader);
73 memcpy((arr + head->size), src, n_bytes);
74 head->size = new_size;
75 return arr;
76}
77
78#endif // BDL_DARRAY_H
diff --git a/src/treewalk/environment.c b/src/treewalk/environment.c
deleted file mode 100644
index dd4a648..0000000
--- a/src/treewalk/environment.c
+++ /dev/null
@@ -1,72 +0,0 @@
1#include "environment.h"
2#include "gc.h"
3#include "errors.h"
4
5Environment *
6env_create(Environment *parent) {
7 Environment *env = alloc_env();
8 env->parent = parent;
9 env->marked = false;
10 env->table = ht_init();
11 return env;
12}
13
14void
15env_add_symbol(Environment *env, Object *symbol, Object *value) {
16 if (symbol->type != OBJ_TYPE_SYMBOL) {
17 error_push((Error){
18 .type = ERR_TYPE_RUNTIME,
19 .value = ERR_NOT_A_SYMBOL,
20 .line = 0,
21 .col = 0,
22 });
23 return;
24 }
25 ht_insert(env->table, symbol, value);
26}
27
28Object *
29env_lookup(Environment *env, Object *symbol) {
30 while (env != NULL) {
31 Object *obj = ht_lookup(env->table, symbol);
32 if (obj != NULL) {
33 return obj;
34 }
35 env = env->parent;
36 }
37 return obj_err;
38}
39
40Object *
41env_update(Environment *env, Object *symbol, Object *value) {
42 while (env != NULL) {
43 Object *obj = ht_lookup(env->table, symbol);
44 if (obj != NULL) {
45 ht_insert(env->table, symbol, value);
46 return obj_nil;
47 }
48 env = env->parent;
49 }
50 error_push((Error){
51 .type = ERR_TYPE_RUNTIME,
52 .value = ERR_SYMBOL_NOT_FOUND,
53 });
54 return obj_err;
55}
56
57void
58env_add_or_update_current(Environment *env, Object *symbol, Object *value) {
59 ht_insert(env->table, symbol, value);
60}
61
62Environment *
63env_extend(Environment *parent, Environment *extra) {
64 Environment *env = parent;
65 HashTablePair *pairs = extra->table->pairs;
66 for (size_t i = 0; i < array_cap(pairs); i++) {
67 if (pairs[i].key != NULL) {
68 ht_insert(env->table, pairs[i].key, pairs[i].value);
69 }
70 }
71 return env;
72}
diff --git a/src/treewalk/environment.h b/src/treewalk/environment.h
deleted file mode 100644
index 5ee21ad..0000000
--- a/src/treewalk/environment.h
+++ /dev/null
@@ -1,27 +0,0 @@
1#ifndef BDL_ENVIRONMENT_H
2#define BDL_ENVIRONMENT_H
3
4#include "objects.h"
5
6typedef struct Environment {
7 struct Environment *parent;
8 HashTable *table;
9 bool marked;
10} Environment;
11
12Environment * env_create(Environment *parent);
13void env_add_symbol(Environment *env, Object *symbol, Object *value);
14Object * env_lookup(Environment *env, Object *symbol);
15Object * env_update(Environment *env, Object *symbol, Object *value);
16ssize_t env_index_current(Environment *env, Object *symbol);
17void env_add_or_update_current(Environment *env, Object *symbol, Object *value);
18Environment * env_extend(Environment *parent, Environment *extra);
19
20#define MAKE_ENV_VAR(ENV,STR,VAR) \
21 (env_add_symbol((ENV), MAKE_SYM(STR), (VAR)))
22#define MAKE_ENV_PROC(ENV,STR,FUN) \
23 (env_add_symbol((ENV), MAKE_SYM(STR), make_procedure(FUN)))
24
25#define ENV_BUF_CAP 8
26
27#endif // BDL_ENVIRONMENT_H
diff --git a/src/treewalk/errors.c b/src/treewalk/errors.c
deleted file mode 100644
index d957cfa..0000000
--- a/src/treewalk/errors.c
+++ /dev/null
@@ -1,29 +0,0 @@
1#include "errors.h"
2
3static const char* error_msgs[] = {
4 [ERR_UNKNOWN] = "error: something unexpected happened",
5 [ERR_UNMATCHED_STRING] = "error: unmatched string delimiter",
6 [ERR_UNBALANCED_PAREN] = "error: unbalanced parentheses",
7 [ERR_NOT_IMPLEMENTED] = "error: not implemented",
8 [ERR_EOF_REACHED] = "error: EOF reached",
9 [ERR_UNKNOWN_TOKEN] = "error: unknown token",
10 [ERR_UNKNOWN_OBJ_TYPE] = "error: can't eval unknown object type",
11 [ERR_NOT_A_SYMBOL] = "error: object is not a symbol",
12 [ERR_SYMBOL_NOT_FOUND] = "error: symbol not found",
13 [ERR_OBJ_NOT_CALLABLE] = "error: object is not callable",
14 [ERR_NOT_ENOUGH_ARGS] = "error: not enough arguments",
15 [ERR_TOO_MANY_ARGS] = "error: too many arguments",
16 [ERR_WRONG_ARG_TYPE] = "error: wrong argument type",
17 [ERR_DIVISION_BY_ZERO] = "error: division by zero",
18};
19
20static Error errors[ERR_MAX_NUMBER];
21static size_t errors_n = 0;
22static bool supress_errors = false;
23
24void
25error_push(Error error) {
26 if (errors_n < ERR_MAX_NUMBER) {
27 errors[errors_n++] = error;
28 }
29}
diff --git a/src/treewalk/errors.h b/src/treewalk/errors.h
deleted file mode 100644
index 7916f4a..0000000
--- a/src/treewalk/errors.h
+++ /dev/null
@@ -1,38 +0,0 @@
1#ifndef BDL_ERRORS_H
2#define BDL_ERRORS_H
3
4typedef enum ErrorType {
5 ERR_TYPE_LEXER,
6 ERR_TYPE_PARSER,
7 ERR_TYPE_RUNTIME,
8} ErrorType;
9
10typedef enum ErrorValue {
11 ERR_UNKNOWN = 0,
12 ERR_UNMATCHED_STRING,
13 ERR_UNBALANCED_PAREN,
14 ERR_NOT_IMPLEMENTED,
15 ERR_EOF_REACHED,
16 ERR_UNKNOWN_TOKEN,
17 ERR_UNKNOWN_OBJ_TYPE,
18 ERR_NOT_A_SYMBOL,
19 ERR_SYMBOL_NOT_FOUND,
20 ERR_OBJ_NOT_CALLABLE,
21 ERR_NOT_ENOUGH_ARGS,
22 ERR_TOO_MANY_ARGS,
23 ERR_WRONG_ARG_TYPE,
24 ERR_DIVISION_BY_ZERO,
25} ErrorValue;
26
27typedef struct Error {
28 ErrorType type;
29 ErrorValue value;
30 size_t line;
31 size_t col;
32} Error;
33
34void error_push(Error error);
35
36#define ERR_MAX_NUMBER 16
37
38#endif // BDL_ERRORS_H
diff --git a/src/treewalk/gc.c b/src/treewalk/gc.c
deleted file mode 100644
index 358a07e..0000000
--- a/src/treewalk/gc.c
+++ /dev/null
@@ -1,199 +0,0 @@
1#include "gc.h"
2
3Environment *
4alloc_env(void) {
5 if (array_size(gc.free_envs.offsets) == 0) {
6 mark_and_sweep();
7 if (array_size(gc.free_envs.offsets) == 0) {
8 fprintf(stderr, "NO MORE ENV MEMORY AVAILABLE WHERE IS YOUR GOD NOW MWAHAHA\n");
9 dump_gc();
10 exit(EXIT_FAILURE);
11 // TODO: grow heap tables.
12 }
13 }
14 size_t slot = gc.free_envs.offsets[gc.free_envs.position++];
15 array_head(gc.free_envs.offsets)->size--;
16 return &gc.envs[slot];
17}
18
19void
20push_root(Object *obj) {
21 array_push(gc.roots, obj);
22}
23
24Object *
25pop_root(void) {
26 return array_pop(gc.roots);
27}
28
29void
30push_active_env(Environment *env) {
31 array_push(gc.active_envs, env);
32}
33
34Environment *
35pop_active_env(void) {
36 return array_pop(gc.active_envs);
37}
38
39void
40gc_init(void) {
41 gc = (GC){0};
42
43 array_init(gc.objects, GC_OBJS_CAP);
44 array_init(gc.roots, GC_ROOTS_CAP);
45 array_init(gc.active_envs, GC_ACTIVE_ENVS_CAP);
46 array_init(gc.envs, GC_ENVS_CAP);
47 array_init(gc.free_objects.offsets, GC_OBJS_CAP);
48 array_init(gc.free_envs.offsets, GC_ENVS_CAP);
49
50 // The free list stores the offset from the initial position for all
51 // available slots.
52 for (size_t i = 0; i < GC_OBJS_CAP; i++) {
53 array_push(gc.free_objects.offsets, i);
54 }
55 for (size_t i = 0; i < GC_ENVS_CAP; i++) {
56 array_push(gc.free_envs.offsets, i);
57 }
58}
59
60void
61mark_environment(Environment *env) {
62 if (env == NULL || env->marked) {
63 return;
64 }
65 env->marked = true;
66 HashTablePair *pairs = env->table->pairs;
67 for (size_t i = 0; i < array_cap(pairs); i++) {
68 if (pairs[i].key != NULL) {
69 mark_obj(pairs[i].key);
70 mark_obj(pairs[i].value);
71 }
72 }
73}
74
75void
76mark_obj(Object *obj) {
77 if (obj->marked) {
78 return;
79 }
80 obj->marked = true;
81 if (obj->type == OBJ_TYPE_PAIR) {
82 mark_obj(obj->car);
83 mark_obj(obj->cdr);
84 }
85 if (obj->type == OBJ_TYPE_LAMBDA) {
86 mark_obj(obj->params);
87 mark_obj(obj->body);
88 mark_environment(obj->env);
89 }
90}
91
92void
93mark_and_sweep(void) {
94 // Mark.
95 for (size_t i = 0; i < array_size(gc.active_envs); i++) {
96 mark_environment(gc.active_envs[i]);
97 }
98 for (size_t i = 0; i < array_size(gc.roots); i++) {
99 mark_obj(gc.roots[i]);
100 }
101
102 // Reset the free list.
103 gc.free_objects.position = 0;
104 array_head(gc.free_objects.offsets)->size = 0;
105 gc.free_envs.position = 0;
106 array_head(gc.free_envs.offsets)->size = 0;
107
108 // Sweep.
109 for (size_t i = 0; i < array_cap(gc.objects); i++) {
110 Object *obj = &gc.objects[i];
111 if (!obj->marked) {
112 // Free heap allocated memory for this object if needed.
113 if (obj->type == OBJ_TYPE_SYMBOL) {
114 array_free(obj->symbol);
115 } else if (obj->type == OBJ_TYPE_STRING) {
116 array_free(obj->string);
117 }
118 gc.free_objects.offsets[array_head(gc.free_objects.offsets)->size++] = i;
119 }
120 obj->marked = false;
121 }
122 for (size_t i = 0; i < array_cap(gc.envs); i++) {
123 Environment *env = &gc.envs[i];
124 if (!env->marked) {
125 ht_free(env->table);
126 gc.free_envs.offsets[array_head(gc.free_envs.offsets)->size++] = i;
127 }
128 env->marked = false;
129 }
130}
131
132void
133dump_gc(void) {
134 printf("-------------- ROOTS -------------- \n");
135 for (size_t i = 0; i < array_size(gc.roots); i++) {
136 display(gc.roots[i]);
137 printf("\n");
138 }
139 printf("--------- OBJECTS (TOP 20) -------- \n");
140 for (size_t i = 0; i < 20; i++) {
141 printf("i: %ld -> ", i);
142 Object *obj = &gc.objects[i];
143 display(obj);
144 bool is_free = false;
145 for (size_t j = 0; j < array_cap(gc.objects); j++) {
146 if (gc.free_objects.offsets[j] == i) {
147 is_free = true;
148 break;
149 }
150 }
151 if (is_free) {
152 printf(" [FREE]");
153 }
154 printf("\n");
155 }
156 printf("-------------- MISC --------------- \n");
157 printf("gc.roots.size: %ld\n", array_size(gc.roots));
158 printf("gc.roots.cap: %ld\n", array_size(gc.roots));
159 printf("gc.active_envs.size: %ld\n", array_size(gc.active_envs));
160 printf("gc.active_envs.cap: %ld\n", array_cap(gc.active_envs));
161 printf("gc.obj_cap: %ld\n", array_cap(gc.objects));
162 printf("gc.free_objects.size: %ld\n", array_size(gc.free_objects.offsets));
163 printf("gc.free_objects.cap: %ld\n", array_cap(gc.free_objects.offsets));
164 printf("gc.free_objects.position: %ld\n", gc.free_objects.position);
165 printf("array_size(gc.free_envs.offsets): %ld\n", array_size(gc.free_envs.offsets));
166 printf("gc.free_envs.cap: %ld\n", array_cap(gc.free_envs.offsets));
167 printf("gc.free_envs.position: %ld\n", gc.free_envs.position);
168 printf("gc.envs.size: %ld\n", array_size(gc.envs));
169 printf("gc.envs.cap: %ld\n", array_cap(gc.envs));
170}
171
172Object *
173alloc_object(ObjectType type) {
174 if (array_head(gc.free_objects.offsets)->size == 0) {
175 mark_and_sweep();
176 if (array_head(gc.free_objects.offsets)->size == 0) {
177 fprintf(stderr, "NO MORE OBJ MEMORY AVAILABLE WHERE IS YOUR GOD NOW MWAHAHA\n");
178 dump_gc();
179 exit(EXIT_FAILURE);
180 // TODO: grow heap tables.
181 // NOTE: When growing the tables, we WILL lose the pointer
182 // references! Should we work with offsets all the way? That is for
183 // cdr and car? Should we have a utility function? All in all, we
184 // need to refactor the codebase first to work with pointer offsets
185 // rather than objects. This issue is very important, if we are in
186 // the middle of an operation that tries to allocate memory but we
187 // had saved pointers to some object, the pointer references may be
188 // invalidated, crashing or worse, silently returning garbage! Let's
189 // move on for now implementing the GC and we will revisit this part
190 // later.
191 }
192 }
193 size_t slot = gc.free_objects.offsets[gc.free_objects.position++];
194 array_head(gc.free_objects.offsets)->size--;
195 Object *obj = &gc.objects[slot];
196 obj->type = type;
197 obj->marked = false;
198 return obj;
199}
diff --git a/src/treewalk/gc.h b/src/treewalk/gc.h
deleted file mode 100644
index 9ad1615..0000000
--- a/src/treewalk/gc.h
+++ /dev/null
@@ -1,46 +0,0 @@
1#ifndef BDL_GC_H
2#define BDL_GC_H
3
4#include "objects.h"
5#include "environment.h"
6
7typedef struct FreeList {
8 size_t *offsets;
9 size_t position;
10} FreeList;
11
12typedef struct GC {
13 Object **roots;
14 Environment *envs;
15 Object *objects;
16 FreeList free_objects;
17 FreeList free_envs;
18 Environment **active_envs;
19} GC;
20
21void gc_init(void);
22
23// Allocation functions for objects and environments.
24Object * alloc_object(ObjectType type);
25Environment * alloc_env(void);
26
27// Root and environment protector functions.
28void push_root(Object *obj);
29Object * pop_root(void);
30void push_active_env(Environment *env);
31Environment * pop_active_env(void);
32
33// Mark and sweep algorithm functions.
34void mark_environment(Environment *env);
35void mark_obj(Object *obj);
36void mark_and_sweep(void);
37
38// Debugging function to print out the contentes of some GC fields.
39void dump_gc(void);
40
41#define GC_OBJS_CAP 1024 * 1024
42#define GC_ROOTS_CAP 1024
43#define GC_ACTIVE_ENVS_CAP 2
44#define GC_ENVS_CAP 1024 * 4
45
46#endif // BDL_GC_H
diff --git a/src/treewalk/hashtable.h b/src/treewalk/hashtable.h
deleted file mode 100644
index 8f210e3..0000000
--- a/src/treewalk/hashtable.h
+++ /dev/null
@@ -1,191 +0,0 @@
1#ifndef BDL_HASHTABLE_H
2#define BDL_HASHTABLE_H
3
4#include "darray.h"
5#include "objects.h"
6
7// Minimum table capacity.
8#define HT_MIN_CAP 4
9#define HT_MIN_SHIFT 2
10
11// Adjust the load factor threshold at which the table will grow on insertion.
12#define HT_LOAD_THRESHOLD 0.8
13
14typedef struct HashTablePair {
15 Object *key;
16 Object *value;
17} HashTablePair;
18
19typedef struct HashTable {
20 // All available key-value pairs as a dynamic array.
21 HashTablePair *pairs;
22
23 // This table expects the number of buckets to grow in powers of two. To
24 // speedup the default hashing, we memoize the number of bits equivalent to
25 // that power of 2:
26 //
27 // cap := 1024 = 2 ^ 10, shift_amount := 10
28 //
29 uint8_t shift_amount;
30} HashTable;
31
32// Hash a byte stream using a circular shift + XOR hash function.
33static inline uint64_t
34_xor_shift_hash(const char *key, size_t n) {
35 uint64_t hash = 0x65d9d65f6a19574f;
36 char *last = (char *)key + n;
37 while (key != last) {
38 hash ^= (uint64_t)*key++;
39 hash = (hash << 8) | (hash >> (64 - 8));
40 }
41 return hash;
42}
43
44// Use Fibonacci hashing to map a hash to a value in range of the table.
45static inline uint64_t
46_fibonacci_hash(uint64_t hash, size_t shift_amount) {
47 return (hash * UINT64_C(11400714819323198485)) >> (64 - shift_amount);
48}
49
50uint64_t
51ht_hash(const HashTable *table, const Object *key) {
52 uint64_t hash = 0;
53 switch (key->type) {
54 case OBJ_TYPE_FIXNUM: {
55 hash = key->fixnum;
56 } break;
57 case OBJ_TYPE_STRING: {
58 hash = _xor_shift_hash(key->string, array_size(key->string));
59 } break;
60 case OBJ_TYPE_SYMBOL: {
61 hash = _xor_shift_hash(key->symbol, array_size(key->symbol));
62 } break;
63 case OBJ_TYPE_BOOL:
64 case OBJ_TYPE_NIL:
65 case OBJ_TYPE_PAIR:
66 case OBJ_TYPE_LAMBDA:
67 case OBJ_TYPE_PROCEDURE:
68 case OBJ_TYPE_ERR: {
69 hash = (uintptr_t)key;
70 } break;
71 }
72 hash = _fibonacci_hash(hash, table->shift_amount);
73 return hash;
74}
75
76static inline float
77ht_load_factor(const HashTable *table) {
78 return (float)array_size(table->pairs) / (float)array_cap(table->pairs);
79}
80
81HashTable *
82ht_init(void) {
83 HashTable *table = malloc(sizeof(HashTable));
84 table->pairs = NULL;
85 array_init(table->pairs, HT_MIN_CAP);
86 for (size_t i = 0; i < array_cap(table->pairs); i++) {
87 table->pairs[i] = (HashTablePair){NULL, NULL};
88 }
89 table->shift_amount = HT_MIN_SHIFT;
90 return table;
91}
92
93void
94_ht_insert(HashTable *table, const Object *key, const Object *value) {
95 size_t position = ht_hash(table, key);
96 size_t probe_position = position;
97
98 // Verify the key in that position is free. If not, use linear probing to
99 // find the next free slot.
100 HashTablePair *pairs = table->pairs;
101 while (true) {
102 if (pairs[probe_position].key == NULL) {
103 array_head(pairs)->size++;
104 break;
105 }
106 if (obj_eq(pairs[probe_position].key, key)) {
107 break;
108 }
109 if (probe_position == array_cap(pairs) - 1) {
110 probe_position = 0;
111 } else {
112 probe_position++;
113 }
114 }
115 pairs[probe_position].key = (Object *)key;
116 pairs[probe_position].value = (Object *)value;
117}
118
119void
120_ht_maybe_grow(HashTable *table) {
121 HashTablePair *pairs = table->pairs;
122 if (ht_load_factor(table) < HT_LOAD_THRESHOLD) {
123 return;
124 }
125
126 // Create a new array with 2x capacity.
127 table->pairs = NULL;
128 array_init(table->pairs, array_cap(pairs) * 2);
129 for (size_t i = 0; i < array_cap(table->pairs); i++) {
130 table->pairs[i] = (HashTablePair){NULL, NULL};
131 }
132 table->shift_amount++;
133
134 // Hash everything in the table for the new array capacity.
135 for (size_t i = 0; i < array_cap(pairs); i++) {
136 if (pairs[i].key != NULL) {
137 _ht_insert(table, pairs[i].key, pairs[i].value);
138 }
139 }
140
141 // Free the old array.
142 array_free(pairs);
143}
144
145void
146ht_insert(HashTable *table, const Object *key, const Object *value) {
147 _ht_maybe_grow(table);
148 _ht_insert(table, key, value);
149 return;
150}
151
152Object *
153ht_lookup(const HashTable *table, const Object *key) {
154 size_t position = ht_hash(table, key);
155 size_t probe_position = position;
156
157 // Verify the key in that position is the same. If not perform linear
158 // probing to find it.
159 HashTablePair *pairs = table->pairs;
160 while (true) {
161 if (pairs[probe_position].key == NULL) {
162 return NULL;
163 }
164 if (obj_eq(pairs[probe_position].key, key)) {
165 break;
166 }
167 if (probe_position == array_cap(pairs) - 1) {
168 probe_position = 0;
169 } else {
170 probe_position++;
171 }
172 if (probe_position == position) {
173 return NULL;
174 }
175 }
176 return pairs[probe_position].value;
177}
178
179void
180ht_free(HashTable *table) {
181 if (table == NULL) {
182 return;
183 }
184 if (table->pairs == NULL) {
185 return;
186 }
187 array_free(table->pairs);
188 free(table);
189}
190
191#endif // BDL_HASHTABLE_H
diff --git a/src/treewalk/lexer.c b/src/treewalk/lexer.c
deleted file mode 100644
index 38ca37c..0000000
--- a/src/treewalk/lexer.c
+++ /dev/null
@@ -1,257 +0,0 @@
1#include "lexer.h"
2
3void
4print_token(Token tok) {
5 printf("LINE: %3ld COL: %3ld ", tok.line, tok.column);
6 switch (tok.type) {
7 case TOKEN_LPAREN: {
8 printf("TOKEN_LPAREN");
9 } break;
10 case TOKEN_RPAREN: {
11 printf("TOKEN_RPAREN");
12 } break;
13 case TOKEN_QUOTE: {
14 printf("TOKEN_QUOTE");
15 } break;
16 case TOKEN_TRUE: {
17 printf("TOKEN_TRUE");
18 } break;
19 case TOKEN_FALSE: {
20 printf("TOKEN_FALSE");
21 } break;
22 case TOKEN_NIL: {
23 printf("TOKEN_NIL");
24 } break;
25 case TOKEN_FIXNUM: {
26 printf("TOKEN_FIXNUM -> ");
27 sv_write(&tok.value, stdout);
28 } break;
29 case TOKEN_SYMBOL: {
30 printf("TOKEN_SYMBOL -> ");
31 sv_write(&tok.value, stdout);
32 } break;
33 case TOKEN_STRING: {
34 printf("TOKEN_STRING -> ");
35 sv_write(&tok.value, stdout);
36 } break;
37 case TOKEN_EOF: {
38 printf("TOKEN_EOF");
39 } break;
40 case TOKEN_UNKNOWN: {
41 printf("TOKEN_UNKNOWN");
42 } break;
43 }
44 printf("\n");
45}
46
47char
48scan_next(Scanner *scanner) {
49 char c = sv_next(&scanner->current);
50 if (c == '\n') {
51 scanner->line_number++;
52 scanner->col_number = 1;
53 } else {
54 scanner->col_number++;
55 }
56 scanner->offset++;
57 return c;
58}
59
60char
61scan_peek(const Scanner *scanner) {
62 return sv_peek(&scanner->current);
63}
64
65bool
66scan_has_next(const Scanner *scanner) {
67 return scanner->current.n != 0;
68}
69
70void
71skip_whitespace(Scanner *scanner) {
72 while (scan_has_next(scanner)) {
73 char c = scan_peek(scanner);
74 switch (c) {
75 case ' ':
76 case '\f':
77 case '\n':
78 case '\r':
79 case '\t':
80 case '\v': {
81 scan_next(scanner);
82 } break;
83 default: {
84 return;
85 } break;
86 }
87 }
88}
89
90bool
91is_delimiter(char c) {
92 switch (c) {
93 case EOF:
94 case '\0':
95 case ';':
96 case '"':
97 case '\'':
98 case '(':
99 case ')':
100 case ' ':
101 case '\f':
102 case '\n':
103 case '\r':
104 case '\t':
105 case '\v': {
106 return true;
107 } break;
108 }
109 return false;
110}
111
112TokenType
113find_primitive_type(const StringView value) {
114 bool is_fixnum = true;
115 for (size_t i = 0; i < value.n; i++) {
116 char c = value.start[i];
117 if (i == 0 && c == '-' && value.n > 1) {
118 continue;
119 }
120 if (!(c >= '0' && c <= '9')) {
121 is_fixnum = false;
122 break;
123 }
124 }
125 if (is_fixnum) {
126 return TOKEN_FIXNUM;
127 }
128 if (sv_equal(&value, &(StringView){"true", 4})) {
129 return TOKEN_TRUE;
130 }
131 if (sv_equal(&value, &(StringView){"false", 5})) {
132 return TOKEN_FALSE;
133 }
134 return TOKEN_SYMBOL;
135}
136
137Token *
138tokenize(const StringView *sv) {
139 Token *tokens = NULL;
140 array_init(tokens, 1);
141 Scanner scanner = (Scanner){
142 .current = *sv,
143 .line_number = 1,
144 .col_number = 1,
145 };
146
147 while (scan_has_next(&scanner)) {
148 skip_whitespace(&scanner);
149 size_t line = scanner.line_number;
150 size_t col = scanner.col_number;
151 size_t offset = scanner.offset;
152 char c = scan_next(&scanner);
153 switch (c) {
154 case ';': {
155 while ((c = scan_next(&scanner)) != '\n' && c != '\0') {}
156 } break;
157 case '"': {
158 char prev = c;
159 bool found = false;
160 size_t n = 0;
161 while (scan_has_next(&scanner)) {
162 c = scan_next(&scanner);
163 if (c == '"' && prev != '\\') {
164 found = true;
165 break;
166 }
167 prev = c;
168 n++;
169 }
170 if (!found) {
171 error_push((Error){
172 .type = ERR_TYPE_LEXER,
173 .value = ERR_UNMATCHED_STRING,
174 .line = line,
175 .col = col,
176 });
177 return tokens;
178 }
179 Token token = (Token){
180 .value = (StringView){
181 .start = &sv->start[offset + 1],
182 .n = n,
183 },
184 .type = TOKEN_STRING,
185 .line = line,
186 .column = col,
187 };
188 array_push(tokens, token);
189 } break;
190 case '\'': {
191 Token token = (Token){
192 .type = TOKEN_QUOTE,
193 .line = line,
194 .column = col,
195 };
196 array_push(tokens, token);
197 } break;
198 case '(': {
199 if (scan_peek(&scanner) == ')') {
200 scan_next(&scanner);
201 Token token = (Token){
202 .type = TOKEN_NIL,
203 .line = line,
204 .column = col,
205 };
206 array_push(tokens, token);
207 } else {
208 Token token = (Token){
209 .type = TOKEN_LPAREN,
210 .line = line,
211 .column = col,
212 };
213 array_push(tokens, token);
214 }
215 } break;
216 case ')': {
217 Token token = (Token){
218 .type = TOKEN_RPAREN,
219 .line = line,
220 .column = col,
221 };
222 array_push(tokens, token);
223 } break;
224 default: {
225 size_t n = 1;
226 while (!is_delimiter(scan_peek(&scanner))) {
227 scan_next(&scanner);
228 n++;
229 }
230 if (c == EOF || c == '\0') {
231 break;
232 }
233 Token token = (Token){
234 .value = (StringView){
235 .start = &sv->start[offset],
236 .n = n,
237 },
238 .type = TOKEN_SYMBOL,
239 .line = line,
240 .column = col,
241 };
242 token.type = find_primitive_type(token.value);
243 array_push(tokens, token);
244 } break;
245 }
246 }
247
248 // Push EOF token.
249 Token token = (Token){
250 .type = TOKEN_EOF,
251 .line = scanner.line_number,
252 .column = 1,
253 };
254 array_push(tokens, token);
255
256 return tokens;
257}
diff --git a/src/treewalk/lexer.h b/src/treewalk/lexer.h
deleted file mode 100644
index 2b2789f..0000000
--- a/src/treewalk/lexer.h
+++ /dev/null
@@ -1,57 +0,0 @@
1#ifndef BDL_LEXER_H
2#define BDL_LEXER_H
3
4typedef enum TokenType {
5 TOKEN_UNKNOWN = 0,
6 TOKEN_LPAREN,
7 TOKEN_RPAREN,
8 TOKEN_QUOTE,
9 TOKEN_TRUE,
10 TOKEN_FALSE,
11 TOKEN_NIL,
12 TOKEN_FIXNUM,
13 TOKEN_SYMBOL,
14 TOKEN_STRING,
15 TOKEN_EOF,
16} TokenType;
17
18typedef struct Token {
19 TokenType type;
20 StringView value;
21 size_t line;
22 size_t column;
23} Token;
24
25typedef struct Scanner {
26 StringView current;
27 size_t line_number;
28 size_t col_number;
29 size_t offset;
30} Scanner;
31
32// Print a token to standard output for debugging purposes.
33void print_token(Token tok);
34
35// Same functionality as the ScanView pairs, but keeping track of line and
36// column numbers.
37char scan_next(Scanner *scanner);
38char scan_peek(const Scanner *scanner);
39
40// Check if the current scanner still have characters left.
41bool scan_has_next(const Scanner *scanner);
42
43// Advance the scanner until we ran out of whitespace.
44void skip_whitespace(Scanner *scanner);
45
46// Check if a given character is a delimiter.
47bool is_delimiter(char c);
48
49// Extract the token type from the current string.
50TokenType find_primitive_type(const StringView value);
51
52// Generate a list of tokens from the given string.
53Token * tokenize(const StringView *sv);
54
55#define TOK_BUF_CAP 256
56
57#endif // BDL_LEXER_H
diff --git a/src/treewalk/main.c b/src/treewalk/main.c
deleted file mode 100755
index a5888fd..0000000
--- a/src/treewalk/main.c
+++ /dev/null
@@ -1,288 +0,0 @@
1#include <assert.h>
2#include <getopt.h>
3#include <stdbool.h>
4#include <stdint.h>
5#include <stdio.h>
6#include <stdlib.h>
7#include <string.h>
8
9#include "darray.h"
10#include "hashtable.h"
11
12#include "singletons.c"
13
14#include "environment.c"
15#include "errors.c"
16#include "gc.c"
17#include "lexer.c"
18#include "objects.c"
19#include "parser.c"
20#include "primitives.c"
21#include "read_line.c"
22#include "string_view.c"
23
24void
25init(void) {
26 // Initialize garbage collector.
27 gc_init();
28
29 // Initialize singletons.
30 obj_nil = alloc_object(OBJ_TYPE_NIL);
31 obj_true = alloc_object(OBJ_TYPE_BOOL);
32 obj_false = alloc_object(OBJ_TYPE_BOOL);
33 obj_err = alloc_object(OBJ_TYPE_ERR);
34 obj_quote = make_symbol((StringView){"quote", 5});
35 proc_if = alloc_object(OBJ_TYPE_ERR);
36 push_root(obj_nil);
37 push_root(obj_true);
38 push_root(obj_false);
39 push_root(obj_err);
40 push_root(obj_quote);
41 push_root(proc_if);
42
43 // Global environment.
44 global_env = env_create(NULL);
45 // TODO: make sure we create symbols and strings only once (interning
46 // strings?)
47 push_active_env(global_env);
48
49 // Primitive symbols.
50 MAKE_ENV_VAR(global_env, "else", obj_true);
51 MAKE_ENV_VAR(global_env, "nil", obj_nil);
52 MAKE_ENV_VAR(global_env, "if", proc_if);
53
54 // Primitive procedures.
55 MAKE_ENV_PROC(global_env, "eval", proc_eval);
56 MAKE_ENV_PROC(global_env, "quote", proc_quote);
57 MAKE_ENV_PROC(global_env, "car", proc_car);
58 MAKE_ENV_PROC(global_env, "cdr", proc_cdr);
59 MAKE_ENV_PROC(global_env, "cons", proc_cons);
60 MAKE_ENV_PROC(global_env, "list", proc_list);
61 MAKE_ENV_PROC(global_env, "+", proc_sum);
62 MAKE_ENV_PROC(global_env, "-", proc_sub);
63 MAKE_ENV_PROC(global_env, "*", proc_mul);
64 MAKE_ENV_PROC(global_env, "/", proc_div);
65 MAKE_ENV_PROC(global_env, "%", proc_mod);
66 MAKE_ENV_PROC(global_env, "print", proc_print);
67 MAKE_ENV_PROC(global_env, "display", proc_display);
68 MAKE_ENV_PROC(global_env, "newline", proc_newline);
69 MAKE_ENV_PROC(global_env, "boolean?", proc_is_boolean);
70 MAKE_ENV_PROC(global_env, "nil?", proc_is_nil);
71 MAKE_ENV_PROC(global_env, "symbol?", proc_is_symbol);
72 MAKE_ENV_PROC(global_env, "string?", proc_is_string);
73 MAKE_ENV_PROC(global_env, "fixnum?", proc_is_fixnum);
74 MAKE_ENV_PROC(global_env, "pair?", proc_is_pair);
75 MAKE_ENV_PROC(global_env, "procedure?", proc_is_procedure);
76 MAKE_ENV_PROC(global_env, "error?", proc_is_error);
77 MAKE_ENV_PROC(global_env, "not", proc_not);
78 MAKE_ENV_PROC(global_env, "and", proc_and);
79 MAKE_ENV_PROC(global_env, "or", proc_or);
80 MAKE_ENV_PROC(global_env, "cond", proc_cond);
81 MAKE_ENV_PROC(global_env, "<", proc_num_less_than);
82 MAKE_ENV_PROC(global_env, "<=", proc_num_lesseq_than);
83 MAKE_ENV_PROC(global_env, ">", proc_num_greater_than);
84 MAKE_ENV_PROC(global_env, ">=", proc_num_greatereq_than);
85 MAKE_ENV_PROC(global_env, "=", proc_num_equal);
86 MAKE_ENV_PROC(global_env, "eq?", proc_equal);
87 MAKE_ENV_PROC(global_env, "def", proc_define);
88 MAKE_ENV_PROC(global_env, "set!", proc_set);
89 MAKE_ENV_PROC(global_env, "lambda", proc_lambda);
90 MAKE_ENV_PROC(global_env, "fun", proc_fun);
91
92 // Runtime procedures.
93 MAKE_ENV_PROC(global_env, "supress-errors", proc_supress_errors);
94}
95
96void
97process_source(const StringView *source) {
98 Token *tokens = tokenize(source);
99 if (errors_n != 0) {
100 if (tokens != NULL) {
101 array_free(tokens);
102 }
103 return;
104 }
105
106 Visitor visitor = (Visitor){
107 .tokens = tokens,
108 .current = 0,
109 };
110 while (has_next_token(&visitor) && peek_token(&visitor).type != TOKEN_EOF) {
111 // Check the root node stack size before parsing
112 size_t root_stack_size = array_size(gc.roots);
113 Object *root = parse_tree(&visitor);
114 array_head(gc.roots)->size = root_stack_size;
115 if (root == obj_err || errors_n != 0) {
116 break;
117 }
118 push_root(root);
119
120 Object *result = eval(global_env, root);
121 if (result != obj_nil) {
122 display(result);
123 printf("\n");
124 }
125 pop_root();
126 }
127
128 if (tokens != NULL) {
129 array_free(tokens);
130 }
131}
132
133#define REPL_PROMPT "bdl> "
134
135void
136run_repl(void) {
137 printf("BDL REPL (Press Ctrl-D or Ctrl-C to exit)\n");
138 while (true) {
139 printf(REPL_PROMPT);
140 StringView sv = read_line();
141 if (sv.start == NULL) {
142 return;
143 }
144 process_source(&sv);
145
146 // Check if there were any errors.
147 if (errors_n != 0 && !supress_errors) {
148 for (size_t i = 0; i < errors_n; i++) {
149 Error err = errors[i];
150 for (size_t j = 0; j < err.col + sizeof(REPL_PROMPT) - 2; j++) {
151 putchar(' ');
152 }
153 printf("|\n");
154 for (size_t j = 0; j < err.col + sizeof(REPL_PROMPT) - 2; j++) {
155 putchar(' ');
156 }
157 printf("%s\n", error_msgs[err.value]);
158 }
159 errors_n = 0;
160 continue;
161 }
162 }
163}
164
165void
166run_file(char *file_name) {
167 FILE *file = fopen(file_name, "r");
168 if (!file) {
169 fprintf(stderr, "error: couldn't open input file: %s\n", file_name);
170 exit(EXIT_FAILURE);
171 }
172
173 // Read entire file into memory.
174 fseek(file, 0, SEEK_END);
175 size_t file_size = ftell(file);
176 fseek(file, 0, SEEK_SET);
177
178 char *source = malloc(file_size + 1);
179 fread(source, 1, file_size, file);
180 source[file_size] = 0;
181
182 StringView sv = (StringView){
183 .start = source,
184 .n = file_size,
185 };
186
187 process_source(&sv);
188
189 // Check if there were any errors.
190 if (errors_n != 0 && !supress_errors) {
191 for (size_t i = 0; i < errors_n; i++) {
192 Error err = errors[i];
193 fprintf(stderr, "%s", file_name);
194 if (err.line != 0) {
195 fprintf(stderr, ":%ld:%ld", err.line, err.col);
196 }
197 fprintf(stderr, ": %s\n", error_msgs[err.value]);
198 }
199 errors_n = 0;
200 }
201
202 free(source);
203 fclose(file);
204}
205
206#define STDIN_BUF_CAP 16
207
208void
209run_stdin(void) {
210 size_t buf_size = 0;
211 char *source = NULL;
212 array_init(source, STDIN_BUF_CAP);
213
214 char c;
215 while ((c = getchar()) != EOF) {
216 array_push(source, c);
217 buf_size++;
218 }
219
220 StringView sv = (StringView){
221 .start = source,
222 .n = buf_size,
223 };
224
225 process_source(&sv);
226
227 // Check if there were any errors.
228 if (errors_n != 0 && !supress_errors) {
229 for (size_t i = 0; i < errors_n; i++) {
230 Error err = errors[i];
231 fprintf(stderr, "stdin");
232 if (err.line != 0) {
233 fprintf(stderr, ":%ld:%ld", err.line, err.col);
234 }
235 fprintf(stderr, ": %s\n", error_msgs[err.value]);
236 }
237 errors_n = 0;
238 }
239
240 array_free(source);
241}
242
243#ifndef BIN_NAME
244#define BIN_NAME "bdl"
245#endif
246
247void
248print_usage(void) {
249 printf("Usage: %s [options] <filename filename ...>\n", BIN_NAME);
250 printf("\n");
251 printf("\t-i\tInteractive mode (REPL).\n");
252 printf("\n");
253}
254
255int
256main(int argc, char *argv[]) {
257 init();
258
259 int option;
260 while ((option = getopt(argc, argv, "i")) != -1) {
261 switch (option) {
262 case 'i': {
263 // Interactive mode.
264 run_repl();
265 return EXIT_SUCCESS;
266 } break;
267 default: {
268 print_usage();
269 return EXIT_FAILURE;
270 } break;
271 }
272 }
273
274 // Run from stdin.
275 if (optind == argc) {
276 run_stdin();
277 return EXIT_SUCCESS;
278 }
279
280 // Run from file.
281 while (optind < argc) {
282 char *file_name = argv[optind];
283 run_file(file_name);
284 optind++;
285 }
286
287 return EXIT_SUCCESS;
288}
diff --git a/src/treewalk/objects.c b/src/treewalk/objects.c
deleted file mode 100644
index c71bc40..0000000
--- a/src/treewalk/objects.c
+++ /dev/null
@@ -1,141 +0,0 @@
1#include "gc.h"
2#include "objects.h"
3
4//
5// Constructors.
6//
7
8Object *
9make_fixnum(ssize_t num) {
10 Object *obj = alloc_object(OBJ_TYPE_FIXNUM);
11 obj->fixnum = num;
12 return obj;
13}
14
15Object *
16make_procedure(Object *(*proc)(struct Environment *, struct Object *args)) {
17 Object *obj = alloc_object(OBJ_TYPE_PROCEDURE);
18 obj->proc = proc;
19 return obj;
20}
21
22Object *
23make_pair(Object *car, Object *cdr) {
24 Object *obj = alloc_object(OBJ_TYPE_PAIR);
25 obj->car = car;
26 obj->cdr = cdr;
27 return obj;
28}
29
30Object *
31make_symbol(StringView sv) {
32 Object *obj = alloc_object(OBJ_TYPE_SYMBOL);
33 obj->symbol = NULL;
34 array_init(obj->symbol, sv.n);
35 array_insert(obj->symbol, sv.start, sv.n);
36 return obj;
37}
38
39Object *
40make_string(void) {
41 Object *obj = alloc_object(OBJ_TYPE_STRING);
42 obj->string = NULL;
43 array_init(obj->string, 0);
44 return obj;
45}
46
47void
48append_string(Object *obj, const StringView sv) {
49 if (sv.n == 0) {
50 return;
51 }
52 array_insert(obj->string, sv.start, sv.n);
53}
54
55void
56display_pair(Object *root) {
57 display(root->car);
58 if (root->cdr->type == OBJ_TYPE_PAIR) {
59 printf(" ");
60 display_pair(root->cdr);
61 } else if (root->cdr == obj_nil) {
62 return;
63 } else {
64 printf(" . ");
65 display(root->cdr);
66 }
67}
68
69void
70display(Object *root) {
71 switch (root->type) {
72 case OBJ_TYPE_FIXNUM: {
73 printf("%zd", root->fixnum);
74 } break;
75 case OBJ_TYPE_BOOL: {
76 if (root == obj_true) {
77 printf("true");
78 } else {
79 printf("false");
80 }
81 } break;
82 case OBJ_TYPE_NIL: {
83 printf("()");
84 } break;
85 case OBJ_TYPE_STRING: {
86 printf("\"%.*s\"", (int)array_size(root->string), root->string);
87 } break;
88 case OBJ_TYPE_SYMBOL: {
89 printf(":%.*s", (int)array_size(root->symbol), root->symbol);
90 } break;
91 case OBJ_TYPE_PAIR: {
92 printf("(");
93 display_pair(root);
94 printf(")");
95 } break;
96 case OBJ_TYPE_LAMBDA:
97 case OBJ_TYPE_PROCEDURE: {
98 printf("#{procedure}");
99 } break;
100 case OBJ_TYPE_ERR: {
101 printf("#{error}");
102 } break;
103 }
104 return;
105}
106
107bool
108obj_eq(const Object *a, const Object* b) {
109 if (a->type != b->type) {
110 return false;
111 }
112 switch (a->type) {
113 case OBJ_TYPE_FIXNUM: {
114 return a->fixnum == b->fixnum;
115 } break;
116 case OBJ_TYPE_STRING: {
117 if (array_size(a->string) != array_size(b->string)) {
118 return false;
119 }
120 for (size_t i = 0; i < array_size(a->string); i++) {
121 if (a->string[i] != b->string[i]) {
122 return false;
123 }
124 }
125 } break;
126 case OBJ_TYPE_SYMBOL: {
127 if (array_size(a->symbol) != array_size(b->symbol)) {
128 return false;
129 }
130 for (size_t i = 0; i < array_size(a->symbol); i++) {
131 if (a->symbol[i] != b->symbol[i]) {
132 return false;
133 }
134 }
135 } break;
136 default: {
137 return a == b;
138 } break;
139 }
140 return true;
141}
diff --git a/src/treewalk/objects.h b/src/treewalk/objects.h
deleted file mode 100644
index ed623eb..0000000
--- a/src/treewalk/objects.h
+++ /dev/null
@@ -1,75 +0,0 @@
1#ifndef BDL_OBJECTS_H
2#define BDL_OBJECTS_H
3
4#include "string_view.h"
5
6typedef enum ObjectType {
7 OBJ_TYPE_FIXNUM,
8 OBJ_TYPE_BOOL,
9 OBJ_TYPE_NIL,
10 OBJ_TYPE_SYMBOL,
11 OBJ_TYPE_STRING,
12 OBJ_TYPE_PAIR,
13 OBJ_TYPE_PROCEDURE,
14 OBJ_TYPE_LAMBDA,
15 OBJ_TYPE_ERR,
16} ObjectType;
17
18struct Environment;
19
20typedef struct Object {
21 ObjectType type;
22 bool marked;
23 union {
24 // OBJ_TYPE_FIXNUM
25 ssize_t fixnum;
26
27 // OBJ_TYPE_STRING
28 struct {
29 char *string;
30 };
31
32 // OBJ_TYPE_PAIR
33 struct {
34 struct Object *car;
35 struct Object *cdr;
36 };
37
38 // OBJ_TYPE_SYMBOL
39 struct {
40 char *symbol;
41 };
42
43 // OBJ_TYPE_PROCEDURE
44 struct Object *(*proc)(struct Environment *env, struct Object *args);
45
46 // OBJ_TYPE_LAMBDA
47 struct {
48 struct Object *params;
49 struct Object *body;
50 struct Environment *env;
51 };
52 };
53} Object;
54
55// Object constructors.
56Object * make_fixnum(ssize_t num);
57Object * make_procedure(Object *(*proc)(struct Environment *, Object *args));
58Object * make_pair(Object *car, Object *cdr);
59Object * make_symbol(StringView sv);
60Object * make_string(void);
61void append_string(Object *obj, const StringView sv);
62
63// Object representation.
64void display(Object *root);
65void display_pair(Object *root);
66
67// Object comparison.
68bool obj_eq(const Object *a, const Object* b);
69
70// Utility macros.
71#define DEBUG_OBJ(MSG,OBJ) printf((MSG)); display(OBJ); printf("\n");
72#define PRINT_OBJ(OBJ) display(OBJ); printf("\n");
73#define MAKE_SYM(STR) make_symbol((StringView){(STR), sizeof(STR) - 1})
74
75#endif // BDL_OBJECTS_H
diff --git a/src/treewalk/parser.c b/src/treewalk/parser.c
deleted file mode 100644
index a2f0f71..0000000
--- a/src/treewalk/parser.c
+++ /dev/null
@@ -1,139 +0,0 @@
1#include "parser.h"
2
3Token
4peek_token(const Visitor *visitor) {
5 return visitor->tokens[visitor->current];
6}
7
8Token
9next_token(Visitor *visitor) {
10 return visitor->tokens[visitor->current++];
11}
12
13bool
14has_next_token(const Visitor *visitor) {
15 return visitor->current < array_size(visitor->tokens);
16}
17
18Object *
19parse_fixnum(Token tok) {
20 ssize_t num = 0;
21 int sign = 1;
22 for (size_t i = 0; i < tok.value.n; i++) {
23 char c = tok.value.start[i];
24 if (c == '-') {
25 sign = -1;
26 continue;
27 }
28 num = num * 10 + (c - '0');
29 }
30
31 Object *obj = make_fixnum(num * sign);
32 push_root(obj);
33 return obj;
34}
35
36Object *
37parse_list(Visitor *vs) {
38 Token tok = peek_token(vs);
39 if (tok.type == TOKEN_EOF) {
40 return obj_err;
41 }
42 Object *root = make_pair(obj_nil, obj_nil);
43 push_root(root);
44 Object *next_obj = parse_tree(vs);
45 if (next_obj == obj_err) {
46 return obj_err;
47 }
48 root->car = next_obj;
49 Object *list = root;
50 while (has_next_token(vs)) {
51 Token tok = peek_token(vs);
52 if (tok.type == TOKEN_RPAREN) {
53 next_token(vs);
54 break;
55 }
56 if (tok.type == TOKEN_EOF) {
57 return obj_err;
58 }
59 next_obj = parse_tree(vs);
60 if (next_obj == obj_err) {
61 return obj_err;
62 }
63 list->cdr = make_pair(next_obj, obj_nil);
64 list = list->cdr;
65 }
66 return root;
67}
68
69Object *
70parse_tree(Visitor *vs) {
71 Token tok = next_token(vs);
72 switch (tok.type) {
73 case TOKEN_FIXNUM: {
74 return parse_fixnum(tok);
75 } break;
76 case TOKEN_TRUE: {
77 return obj_true;
78 } break;
79 case TOKEN_FALSE: {
80 return obj_false;
81 } break;
82 case TOKEN_RPAREN: {
83 error_push((Error){
84 .type = ERR_TYPE_PARSER,
85 .value = ERR_UNBALANCED_PAREN,
86 .line = tok.line,
87 .col = tok.column,
88 });
89 return obj_err;
90 } break;
91 case TOKEN_QUOTE: {
92 Object *base = make_pair(obj_quote, obj_nil);
93 base->cdr = make_pair(obj_nil, obj_nil);
94 push_root(base);
95 Object *next_obj = parse_tree(vs);
96 if (next_obj == obj_err) {
97 return obj_err;
98 }
99 base->cdr->car = next_obj;
100 return base;
101 } break;
102 case TOKEN_LPAREN: {
103 Object *obj = parse_list(vs);
104 if (obj == obj_err) {
105 error_push((Error){
106 .type = ERR_TYPE_PARSER,
107 .value = ERR_UNBALANCED_PAREN,
108 .line = tok.line,
109 .col = tok.column,
110 });
111 }
112 return obj;
113 } break;
114 case TOKEN_STRING: {
115 Object *obj = make_string();
116 push_root(obj);
117 append_string(obj, tok.value);
118 return obj;
119 } break;
120 case TOKEN_SYMBOL: {
121 Object *obj = make_symbol(tok.value);
122 push_root(obj);
123 return obj;
124 } break;
125 case TOKEN_NIL: {
126 return obj_nil;
127 } break;
128 default: {
129 break;
130 } break;
131 }
132 error_push((Error){
133 .type = ERR_TYPE_PARSER,
134 .value = ERR_EOF_REACHED,
135 .line = tok.line,
136 .col = tok.column,
137 });
138 return obj_err;
139}
diff --git a/src/treewalk/parser.h b/src/treewalk/parser.h
deleted file mode 100644
index 3834c75..0000000
--- a/src/treewalk/parser.h
+++ /dev/null
@@ -1,22 +0,0 @@
1#ifndef BDL_PARSER_H
2#define BDL_PARSER_H
3
4typedef struct Visitor {
5 Token *tokens;
6 size_t current;
7} Visitor;
8
9// Mimics the functionality in the Scanner functions, but for entire tokens.
10Token next_token(Visitor *visitor);
11Token peek_token(const Visitor *visitor);
12bool has_next_token(const Visitor *visitor);
13
14// Parse a token into a fixnum object.
15Object * parse_fixnum(Token tok);
16
17// Recursive descent parser. If an object is not a list the parsing is handled
18// by the parse_tree function.
19Object * parse_list(Visitor *vs);
20Object * parse_tree(Visitor *vs);
21
22#endif // BDL_PARSER_H
diff --git a/src/treewalk/primitives.c b/src/treewalk/primitives.c
deleted file mode 100644
index 8b0d407..0000000
--- a/src/treewalk/primitives.c
+++ /dev/null
@@ -1,918 +0,0 @@
1#include "primitives.h"
2
3Object *
4eval(Environment *env, Object *root) {
5 Object* lambda = NULL;
6 Object* args = NULL;
7 Object* ret = NULL;
8 bool recursion_active = false;
9eval_start:
10 switch (root->type) {
11 case OBJ_TYPE_ERR:
12 case OBJ_TYPE_PROCEDURE:
13 case OBJ_TYPE_LAMBDA:
14 case OBJ_TYPE_FIXNUM:
15 case OBJ_TYPE_BOOL:
16 case OBJ_TYPE_NIL:
17 case OBJ_TYPE_STRING: {
18 ret = root;
19 goto eval_success;
20 } break;
21 case OBJ_TYPE_SYMBOL: {
22 Object *val = env_lookup(env, root);
23 if (val == obj_err) {
24 error_push((Error){
25 .type = ERR_TYPE_RUNTIME,
26 .value = ERR_SYMBOL_NOT_FOUND,
27 });
28 return obj_err;
29 }
30 ret = val;
31 goto eval_success;
32 } break;
33 case OBJ_TYPE_PAIR: {
34 if (root->car->type == OBJ_TYPE_SYMBOL) {
35 Object *val = env_lookup(env, root->car);
36 if (val == obj_err) {
37 error_push((Error){
38 .type = ERR_TYPE_RUNTIME,
39 .value = ERR_SYMBOL_NOT_FOUND,
40 });
41 return obj_err;
42 }
43
44 // Primitive `if` procedure with TCO.
45 if (val == proc_if) {
46 Object *obj = root->cdr;
47 if (obj == obj_nil || obj->cdr == obj_nil) {
48 error_push((Error){
49 .type = ERR_TYPE_RUNTIME,
50 .value = ERR_NOT_ENOUGH_ARGS,
51 });
52 return obj_err;
53 }
54 Object *car = obj->car;
55 Object *cdr = obj->cdr;
56 Object *condition = eval(env, car);
57 if (condition == obj_err) {
58 return obj_err;
59 }
60 if (condition == obj_true) {
61 root = cdr->car;
62 } else if (cdr->cdr != obj_nil) {
63 root = cdr->cdr->car;
64 } else {
65 return obj_nil;
66 }
67 goto eval_start;
68 }
69
70 if (val->type == OBJ_TYPE_PROCEDURE) {
71 ret = val->proc(env, root->cdr);
72 goto eval_success;
73 }
74 if (val->type == OBJ_TYPE_LAMBDA) {
75 lambda = val;
76 goto eval_lambda;
77 }
78 error_push((Error){
79 .type = ERR_TYPE_RUNTIME,
80 .value = ERR_OBJ_NOT_CALLABLE,
81 });
82 return obj_err;
83 }
84 lambda = eval(env, root->car);
85 if (lambda == obj_err) {
86 return obj_err;
87 }
88 if (lambda->type != OBJ_TYPE_LAMBDA) {
89 error_push((Error){
90 .type = ERR_TYPE_RUNTIME,
91 .value = ERR_OBJ_NOT_CALLABLE,
92 });
93 return obj_err;
94 }
95
96eval_lambda:
97 args = root->cdr;
98 Object *params = lambda->params;
99 if (!recursion_active) {
100 recursion_active = true;
101 // Protect current stack.
102 Environment *tmp = env_create(lambda->env);
103 push_active_env(tmp);
104 // Extend environment.
105 env = env_extend(tmp, env);
106 }
107
108 // Create temporary environment to store bindings.
109 Environment *tmp = env_create(env);
110 push_active_env(tmp);
111
112 // Evaluate arguments in temporary environment.
113 while (params != obj_nil) {
114 if (args == obj_nil) {
115 error_push((Error){
116 .type = ERR_TYPE_RUNTIME,
117 .value = ERR_NOT_ENOUGH_ARGS,
118 });
119 return obj_err;
120 }
121 if (args->car == obj_nil) {
122 error_push((Error){
123 .type = ERR_TYPE_RUNTIME,
124 .value = ERR_NOT_ENOUGH_ARGS,
125 });
126 return obj_err;
127 }
128 Object *symbol = params->car;
129 Object *value = eval(env, args->car);
130 if (value == obj_err) {
131 return obj_err;
132 }
133 env_add_or_update_current(tmp, symbol, value);
134 args = args->cdr;
135 params = params->cdr;
136 }
137 if (args != obj_nil) {
138 error_push((Error){
139 .type = ERR_TYPE_RUNTIME,
140 .value = ERR_TOO_MANY_ARGS,
141 });
142 return obj_err;
143 }
144
145 // Copy temporary environment values to closure environment.
146 args = root->cdr;
147 params = lambda->params;
148 while (params != obj_nil) {
149 Object *symbol = params->car;
150 Object *value = env_lookup(tmp, symbol);
151 env_add_or_update_current(env, symbol, value);
152 args = args->cdr;
153 params = params->cdr;
154 }
155
156 // Release the temporary environment protection.
157 pop_active_env();
158
159 // Run the body of the function.
160 root = lambda->body;
161 while (root->cdr != obj_nil) {
162 if (eval(env, root->car) == obj_err) {
163 return obj_err;
164 };
165 root = root->cdr;
166 }
167 root = root->car;
168 goto eval_start;
169 } break;
170 }
171
172 error_push((Error){
173 .type = ERR_TYPE_RUNTIME,
174 .value = ERR_UNKNOWN_OBJ_TYPE,
175 });
176 return obj_err;
177
178eval_success:
179 if (recursion_active) {
180 // Remove stack protector.
181 pop_active_env();
182 }
183 return ret;
184}
185
186Object *
187proc_quote(Environment *env, Object *obj) {
188 (void)env;
189 return obj->car;
190}
191
192static inline Object *
193extract_car_with_type(Environment *env, Object *obj, ObjectType expected_type) {
194 if (obj == obj_nil) {
195 error_push((Error){
196 .type = ERR_TYPE_RUNTIME,
197 .value = ERR_NOT_ENOUGH_ARGS,
198 });
199 return obj_err;
200 }
201 Object *car = eval(env, obj->car);
202 if (car == obj_err) {
203 return obj_err;
204 }
205 if (car->type != expected_type) {
206 error_push((Error){
207 .type = ERR_TYPE_RUNTIME,
208 .value = ERR_WRONG_ARG_TYPE,
209 });
210 return obj_err;
211 }
212 return car;
213}
214
215//
216// Arithmetic procedures.
217//
218
219Object *
220proc_sum(Environment *env, Object *obj) {
221 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
222 obj = obj->cdr;
223 ssize_t tot = car->fixnum;
224 while (obj != obj_nil) {
225 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
226 tot += car->fixnum;
227 obj = obj->cdr;
228 }
229 return make_fixnum(tot);
230}
231
232Object *
233proc_sub(Environment *env, Object *obj) {
234 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
235 obj = obj->cdr;
236 ssize_t tot = car->fixnum;
237 while (obj != obj_nil) {
238 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
239 tot -= car->fixnum;
240 obj = obj->cdr;
241 }
242 return make_fixnum(tot);
243}
244
245Object *
246proc_mul(Environment *env, Object *obj) {
247 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
248 obj = obj->cdr;
249 ssize_t tot = car->fixnum;
250 while (obj != obj_nil) {
251 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
252 tot *= car->fixnum;
253 obj = obj->cdr;
254 }
255 return make_fixnum(tot);
256}
257
258Object *
259proc_div(Environment *env, Object *obj) {
260 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
261 obj = obj->cdr;
262 ssize_t tot = car->fixnum;
263 while (obj != obj_nil) {
264 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
265 if (car->fixnum == 0) {
266 error_push((Error){
267 .type = ERR_TYPE_RUNTIME,
268 .value = ERR_DIVISION_BY_ZERO,
269 });
270 return obj_err;
271 }
272 tot /= car->fixnum;
273 obj = obj->cdr;
274 }
275 return make_fixnum(tot);
276}
277
278Object *
279proc_mod(Environment *env, Object *obj) {
280 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
281 obj = obj->cdr;
282 ssize_t tot = car->fixnum;
283 while (obj != obj_nil) {
284 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
285 if (car->fixnum == 0) {
286 error_push((Error){
287 .type = ERR_TYPE_RUNTIME,
288 .value = ERR_DIVISION_BY_ZERO,
289 });
290 return obj_err;
291 }
292 tot %= car->fixnum;
293 obj = obj->cdr;
294 }
295 return make_fixnum(tot);
296}
297
298//
299// Display/Evaluation procedues.
300//
301
302Object *
303proc_display(Environment *env, Object *obj) {
304 display(eval(env, obj->car));
305 return obj_nil;
306}
307
308Object *
309proc_print(Environment *env, Object *obj) {
310 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_STRING);
311 StringView scanner = (StringView) {
312 .start = car->string,
313 .n = array_size(car->string),
314 };
315 while (scanner.n != 0) {
316 char c = sv_next(&scanner);
317 if (c == '\\' && sv_peek(&scanner) == 'n') {
318 putchar('\n');
319 sv_next(&scanner);
320 continue;
321 }
322 if (c == '\\' && sv_peek(&scanner) == '"') {
323 putchar('"');
324 sv_next(&scanner);
325 continue;
326 }
327 putchar(c);
328 }
329 return obj_nil;
330}
331
332Object *
333proc_newline(Environment *env, Object *obj) {
334 printf("\n");
335 (void)env;
336 (void)obj;
337 return obj_nil;
338}
339
340//
341// Type info procedures.
342//
343
344Object *
345proc_is_boolean(Environment *env, Object *obj) {
346 if (obj == obj_nil) {
347 error_push((Error){
348 .type = ERR_TYPE_RUNTIME,
349 .value = ERR_NOT_ENOUGH_ARGS,
350 });
351 return obj_err;
352 }
353 obj = eval(env, obj->car);
354 if (obj == obj_err) {
355 return obj_err;
356 }
357 return (obj == obj_true || obj == obj_false) ? obj_true : obj_false;
358}
359
360Object *
361proc_is_nil(Environment *env, Object *obj) {
362 if (obj == obj_nil) {
363 error_push((Error){
364 .type = ERR_TYPE_RUNTIME,
365 .value = ERR_NOT_ENOUGH_ARGS,
366 });
367 return obj_err;
368 }
369 obj = eval(env, obj->car);
370 if (obj == obj_err) {
371 return obj_err;
372 }
373 return obj == obj_nil ? obj_true : obj_false;
374}
375
376Object *
377proc_is_symbol(Environment *env, Object *obj) {
378 if (obj == obj_nil) {
379 error_push((Error){
380 .type = ERR_TYPE_RUNTIME,
381 .value = ERR_NOT_ENOUGH_ARGS,
382 });
383 return obj_err;
384 }
385 obj = eval(env, obj->car);
386 if (obj == obj_err) {
387 return obj_err;
388 }
389 return obj->type == OBJ_TYPE_SYMBOL ? obj_true : obj_false;
390}
391
392Object *
393proc_is_string(Environment *env, Object *obj) {
394 if (obj == obj_nil) {
395 error_push((Error){
396 .type = ERR_TYPE_RUNTIME,
397 .value = ERR_NOT_ENOUGH_ARGS,
398 });
399 return obj_err;
400 }
401 obj = eval(env, obj->car);
402 if (obj == obj_err) {
403 return obj_err;
404 }
405 return obj->type == OBJ_TYPE_STRING ? obj_true : obj_false;
406}
407
408Object *
409proc_is_fixnum(Environment *env, Object *obj) {
410 if (obj == obj_nil) {
411 error_push((Error){
412 .type = ERR_TYPE_RUNTIME,
413 .value = ERR_NOT_ENOUGH_ARGS,
414 });
415 return obj_err;
416 }
417 obj = eval(env, obj->car);
418 if (obj == obj_err) {
419 return obj_err;
420 }
421 return obj->type == OBJ_TYPE_FIXNUM ? obj_true : obj_false;
422}
423
424Object *
425proc_is_pair(Environment *env, Object *obj) {
426 if (obj == obj_nil) {
427 error_push((Error){
428 .type = ERR_TYPE_RUNTIME,
429 .value = ERR_NOT_ENOUGH_ARGS,
430 });
431 return obj_err;
432 }
433 obj = eval(env, obj->car);
434 if (obj == obj_err) {
435 return obj_err;
436 }
437 return obj->type == OBJ_TYPE_PAIR ? obj_true : obj_false;
438}
439
440Object *
441proc_is_procedure(Environment *env, Object *obj) {
442 if (obj == obj_nil) {
443 error_push((Error){
444 .type = ERR_TYPE_RUNTIME,
445 .value = ERR_NOT_ENOUGH_ARGS,
446 });
447 return obj_err;
448 }
449 obj = eval(env, obj->car);
450 if (obj == obj_err) {
451 return obj_err;
452 }
453 return obj->type == OBJ_TYPE_PROCEDURE ? obj_true : obj_false;
454}
455
456Object *
457proc_is_error(Environment *env, Object *obj) {
458 if (obj == obj_nil) {
459 error_push((Error){
460 .type = ERR_TYPE_RUNTIME,
461 .value = ERR_NOT_ENOUGH_ARGS,
462 });
463 return obj_err;
464 }
465 obj = eval(env, obj->car);
466 if (obj == obj_err) {
467 return obj_true;
468 }
469 return obj_false;
470}
471
472//
473// Boolean/conditional procedures.
474//
475
476Object *
477proc_not(Environment *env, Object *obj) {
478 if (obj == obj_nil) {
479 error_push((Error){
480 .type = ERR_TYPE_RUNTIME,
481 .value = ERR_NOT_ENOUGH_ARGS,
482 });
483 return obj_err;
484 }
485 obj = eval(env, obj->car);
486 if (obj == obj_err) {
487 return obj_err;
488 }
489 return obj == obj_false ? obj_true : obj_false;
490}
491
492Object *
493proc_and(Environment *env, Object *obj) {
494 while (obj != obj_nil) {
495 if (proc_not(env, obj) == obj_true) {
496 return obj_false;
497 }
498 obj = obj->cdr;
499 }
500 return obj_true;
501}
502
503Object *
504proc_or(Environment *env, Object *obj) {
505 while (obj != obj_nil) {
506 if (proc_not(env, obj) == obj_false) {
507 return obj_true;
508 }
509 obj = obj->cdr;
510 }
511 return obj_false;
512}
513
514Object *
515proc_cond(Environment *env, Object *obj) {
516 if (obj == obj_nil) {
517 error_push((Error){
518 .type = ERR_TYPE_RUNTIME,
519 .value = ERR_NOT_ENOUGH_ARGS,
520 });
521 return obj_err;
522 }
523 while (obj != obj_nil) {
524 Object *clause = obj->car;
525 if (clause->type != OBJ_TYPE_PAIR || clause->cdr == obj_nil) {
526 error_push((Error){
527 .type = ERR_TYPE_RUNTIME,
528 .value = ERR_WRONG_ARG_TYPE,
529 });
530 return obj_err;
531 }
532 Object *test = clause->car;
533 Object *value = clause->cdr->car;
534 Object *result = eval(env, test);
535 if (result == obj_err) {
536 return obj_err;
537 }
538 if (result == obj_true) {
539 return eval(env, value);
540 }
541 obj = obj->cdr;
542 }
543 return obj_nil;
544}
545
546Object *
547proc_num_less_than(Environment *env, Object *obj) {
548 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
549 obj = obj->cdr;
550 ssize_t prev = car->fixnum;
551 while (obj != obj_nil) {
552 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
553 if (prev >= car->fixnum) {
554 return obj_false;
555 }
556 prev = car->fixnum;
557 obj = obj->cdr;
558 }
559 return obj_true;
560}
561
562Object *
563proc_num_greater_than(Environment *env, Object *obj) {
564 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
565 obj = obj->cdr;
566 ssize_t prev = car->fixnum;
567 while (obj != obj_nil) {
568 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
569 if (prev <= car->fixnum) {
570 return obj_false;
571 }
572 prev = car->fixnum;
573 obj = obj->cdr;
574 }
575 return obj_true;
576}
577
578Object *
579proc_num_lesseq_than(Environment *env, Object *obj) {
580 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
581 obj = obj->cdr;
582 ssize_t prev = car->fixnum;
583 while (obj != obj_nil) {
584 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
585 if (prev > car->fixnum) {
586 return obj_false;
587 }
588 prev = car->fixnum;
589 obj = obj->cdr;
590 }
591 return obj_true;
592}
593
594Object *
595proc_num_greatereq_than(Environment *env, Object *obj) {
596 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
597 obj = obj->cdr;
598 ssize_t prev = car->fixnum;
599 while (obj != obj_nil) {
600 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
601 if (prev < car->fixnum) {
602 return obj_false;
603 }
604 prev = car->fixnum;
605 obj = obj->cdr;
606 }
607 return obj_true;
608}
609
610Object *
611proc_num_equal(Environment *env, Object *obj) {
612 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
613 obj = obj->cdr;
614 ssize_t prev = car->fixnum;
615 while (obj != obj_nil) {
616 car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM);
617 if (prev != car->fixnum) {
618 return obj_false;
619 }
620 prev = car->fixnum;
621 obj = obj->cdr;
622 }
623 return obj_true;
624}
625
626//
627// List operation procedures.
628//
629
630Object *
631proc_car(Environment *env, Object *obj) {
632 if (obj == obj_nil) {
633 error_push((Error){
634 .type = ERR_TYPE_RUNTIME,
635 .value = ERR_NOT_ENOUGH_ARGS,
636 });
637 return obj_err;
638 }
639 obj = eval(env, obj->car);
640 if (obj == obj_err) {
641 return obj_err;
642 }
643 if (obj->type != OBJ_TYPE_PAIR) {
644 error_push((Error){
645 .type = ERR_TYPE_RUNTIME,
646 .value = ERR_WRONG_ARG_TYPE,
647 });
648 return obj_err;
649 }
650 return obj->car;
651}
652
653Object *
654proc_cdr(Environment *env, Object *obj) {
655 if (obj == obj_nil) {
656 error_push((Error){
657 .type = ERR_TYPE_RUNTIME,
658 .value = ERR_NOT_ENOUGH_ARGS,
659 });
660 return obj_err;
661 }
662 obj = eval(env, obj->car);
663 if (obj == obj_err) {
664 return obj_err;
665 }
666 if (obj->type != OBJ_TYPE_PAIR) {
667 error_push((Error){
668 .type = ERR_TYPE_RUNTIME,
669 .value = ERR_WRONG_ARG_TYPE,
670 });
671 return obj_err;
672 }
673 return obj->cdr;
674}
675
676Object *
677proc_cons(Environment *env, Object *obj) {
678 if (obj == obj_nil) {
679 error_push((Error){
680 .type = ERR_TYPE_RUNTIME,
681 .value = ERR_NOT_ENOUGH_ARGS,
682 });
683 return obj_err;
684 }
685 Object *head = make_pair(obj_nil, obj_nil);
686 push_root(head);
687 head->car = eval(env, obj->car);
688 if (head->car == obj_err) {
689 pop_root();
690 return obj_err;
691 }
692 head->cdr = eval(env, obj->cdr->car);
693 if (head->cdr == obj_err) {
694 pop_root();
695 return obj_err;
696 }
697 pop_root();
698 return head;
699}
700
701Object *
702proc_list(Environment *env, Object *obj) {
703 if (obj == obj_nil) {
704 return obj_nil;
705 }
706
707 Object *head = make_pair(obj_nil, obj_nil);
708 push_root(head);
709 Object *tmp = eval(env, obj->car);
710 if (tmp == obj_err) {
711 pop_root();
712 return obj_err;
713 }
714 head->car = tmp;
715 Object *curr = head;
716 obj = obj->cdr;
717 while (obj != obj_nil) {
718 tmp = eval(env, obj->car);
719 if (tmp == obj_err) {
720 pop_root();
721 return obj_err;
722 }
723 curr->cdr = make_pair(tmp, obj_nil);
724 curr = curr->cdr;
725 obj = obj->cdr;
726 }
727 pop_root();
728 return head;
729}
730
731//
732// Polymorphic procedures.
733//
734
735Object *
736proc_equal(Environment *env, Object *obj) {
737 if (obj == obj_nil || obj->cdr == obj_nil) {
738 error_push((Error){
739 .type = ERR_TYPE_RUNTIME,
740 .value = ERR_NOT_ENOUGH_ARGS,
741 });
742 return obj_err;
743 }
744 Object *a = eval(env, obj->car);
745 if (a == obj_err) {
746 return obj_err;
747 }
748 Object *b = eval(env, obj->cdr->car);
749 if (b == obj_err) {
750 return obj_err;
751 }
752 return obj_eq(a, b) ? obj_true : obj_false;
753}
754
755//
756// Variables and declarations.
757//
758
759Object *
760proc_define(Environment *env, Object *obj) {
761 if (obj == obj_nil || obj->cdr == obj_nil) {
762 error_push((Error){
763 .type = ERR_TYPE_RUNTIME,
764 .value = ERR_NOT_ENOUGH_ARGS,
765 });
766 return obj_err;
767 }
768
769 Object *symbol = obj->car;
770 if (symbol->type != OBJ_TYPE_SYMBOL) {
771 error_push((Error){
772 .type = ERR_TYPE_RUNTIME,
773 .value = ERR_WRONG_ARG_TYPE,
774 });
775 return obj_err;
776 }
777
778 Object *value = eval(env, obj->cdr->car);
779 if (value == obj_err) {
780 return obj_err;
781 }
782
783 env_add_or_update_current(env, symbol, value);
784 return obj_nil;
785}
786
787Object *
788proc_set(Environment *env, Object *obj) {
789 if (obj == obj_nil || obj->cdr == obj_nil) {
790 error_push((Error){
791 .type = ERR_TYPE_RUNTIME,
792 .value = ERR_NOT_ENOUGH_ARGS,
793 });
794 return obj_err;
795 }
796
797 Object *symbol = obj->car;
798 if (symbol->type != OBJ_TYPE_SYMBOL) {
799 error_push((Error){
800 .type = ERR_TYPE_RUNTIME,
801 .value = ERR_WRONG_ARG_TYPE,
802 });
803 return obj_err;
804 }
805
806 Object *value = eval(env, obj->cdr->car);
807 if (value == obj_err) {
808 return obj_err;
809 }
810
811 return env_update(env, symbol, value);
812}
813
814Object *
815proc_lambda(Environment *env, Object *obj) {
816 if (obj == obj_nil || obj->cdr == obj_nil) {
817 error_push((Error){
818 .type = ERR_TYPE_RUNTIME,
819 .value = ERR_NOT_ENOUGH_ARGS,
820 });
821 return obj_err;
822 }
823 Object *params = obj->car;
824 if (params != obj_nil && params->type != OBJ_TYPE_PAIR) {
825 error_push((Error){
826 .type = ERR_TYPE_RUNTIME,
827 .value = ERR_WRONG_ARG_TYPE,
828 });
829 return obj_err;
830 }
831 Object *body = obj->cdr;
832 Object *fun = alloc_object(OBJ_TYPE_LAMBDA);
833 fun->params = params;
834 fun->body = body;
835 fun->env = env;
836 return fun;
837}
838
839Object *
840proc_fun(Environment *env, Object *obj) {
841 if (obj == obj_nil || obj->cdr == obj_nil || obj->cdr->cdr == obj_nil) {
842 error_push((Error){
843 .type = ERR_TYPE_RUNTIME,
844 .value = ERR_NOT_ENOUGH_ARGS,
845 });
846 return obj_err;
847 }
848
849 Object *name = obj->car;
850 if (name->type != OBJ_TYPE_SYMBOL) {
851 error_push((Error){
852 .type = ERR_TYPE_RUNTIME,
853 .value = ERR_WRONG_ARG_TYPE,
854 });
855 return obj_err;
856 }
857
858 Object *params = obj->cdr->car;
859 if (params != obj_nil && params->type != OBJ_TYPE_PAIR) {
860 error_push((Error){
861 .type = ERR_TYPE_RUNTIME,
862 .value = ERR_WRONG_ARG_TYPE,
863 });
864 return obj_err;
865 }
866 Object *body = obj->cdr->cdr;
867 Object *fun = alloc_object(OBJ_TYPE_LAMBDA);
868 fun->params = params;
869 fun->body = body;
870 fun->env = env;
871 env_add_or_update_current(env, name, fun);
872 return obj_nil;
873}
874
875//
876// Evaluation.
877//
878
879Object *
880proc_eval(Environment *env, Object *obj) {
881 if (obj == obj_nil) {
882 error_push((Error){
883 .type = ERR_TYPE_RUNTIME,
884 .value = ERR_NOT_ENOUGH_ARGS,
885 });
886 return obj_err;
887 }
888 return eval(env, eval(env, obj->car));
889}
890
891//
892// Runtime configuration options.
893//
894
895Object *
896proc_supress_errors(Environment *env, Object *obj) {
897 Object *car = extract_car_with_type(env, obj, OBJ_TYPE_BOOL);
898 if (car == obj_err) {
899 return obj_err;
900 }
901
902 if (car == obj_true) {
903 supress_errors = true;
904 } else if (car == obj_false) {
905 supress_errors = false;
906 }
907 return obj_nil;
908}
909
910// TODO: map
911// TODO: apply
912// TODO: filter
913
914// TODO: fixnum left/right shift, mask, invert
915// TODO: add primitives for type transforms: string->symbol, symbol->string, etc
916// TODO: implement support for semi-quotes
917// TODO: LAMBDA
918// TODO: let
diff --git a/src/treewalk/primitives.h b/src/treewalk/primitives.h
deleted file mode 100644
index f874b17..0000000
--- a/src/treewalk/primitives.h
+++ /dev/null
@@ -1,60 +0,0 @@
1#ifndef BDL_PRIMITIVES_H
2#define BDL_PRIMITIVES_H
3
4// Function evaluation.
5Object * eval(Environment *env, Object *root);
6
7// Evaluation functions.
8Object * proc_quote(Environment *env, Object *obj);
9Object * proc_eval(Environment *env, Object *obj);
10
11// Arithmetic.
12Object * proc_sum(Environment *env, Object *obj);
13Object * proc_sub(Environment *env, Object *obj);
14Object * proc_mul(Environment *env, Object *obj);
15Object * proc_div(Environment *env, Object *obj);
16Object * proc_mod(Environment *env, Object *obj);
17
18// Printing.
19Object * proc_display(Environment *env, Object *obj);
20Object * proc_print(Environment *env, Object *obj);
21Object * proc_newline(Environment *env, Object *obj);
22
23// Type checking.
24Object * proc_is_boolean(Environment *env, Object *obj);
25Object * proc_is_nil(Environment *env, Object *obj);
26Object * proc_is_symbol(Environment *env, Object *obj);
27Object * proc_is_string(Environment *env, Object *obj);
28Object * proc_is_fixnum(Environment *env, Object *obj);
29Object * proc_is_pair(Environment *env, Object *obj);
30Object * proc_is_procedure(Environment *env, Object *obj);
31Object * proc_is_error(Environment *env, Object *obj);
32
33// Logical operations.
34Object * proc_not(Environment *env, Object *obj);
35Object * proc_and(Environment *env, Object *obj);
36Object * proc_or(Environment *env, Object *obj);
37Object * proc_cond(Environment *env, Object *obj);
38Object * proc_num_less_than(Environment *env, Object *obj);
39Object * proc_num_greater_than(Environment *env, Object *obj);
40Object * proc_num_lesseq_than(Environment *env, Object *obj);
41Object * proc_num_greatereq_than(Environment *env, Object *obj);
42Object * proc_num_equal(Environment *env, Object *obj);
43Object * proc_equal(Environment *env, Object *obj);
44
45// List operations.
46Object * proc_car(Environment *env, Object *obj);
47Object * proc_cdr(Environment *env, Object *obj);
48Object * proc_cons(Environment *env, Object *obj);
49Object * proc_list(Environment *env, Object *obj);
50
51// Environment/variable manipulation.
52Object * proc_define(Environment *env, Object *obj);
53Object * proc_set(Environment *env, Object *obj);
54Object * proc_lambda(Environment *env, Object *obj);
55Object * proc_fun(Environment *env, Object *obj);
56
57// Runtinme configuration.
58Object * proc_supress_errors(Environment *env, Object *obj);
59
60#endif // BDL_PRIMITIVES_H
diff --git a/src/treewalk/read_line.c b/src/treewalk/read_line.c
deleted file mode 100644
index 03146ad..0000000
--- a/src/treewalk/read_line.c
+++ /dev/null
@@ -1,32 +0,0 @@
1#include "read_line.h"
2
3static char readline_buf[RL_BUF_SIZE];
4
5StringView
6read_line(void) {
7 // Clear buffer.
8 for (size_t i = 0; i < RL_BUF_SIZE; i++) {
9 readline_buf[i] = 0;
10 }
11
12 // Barebones readline implementation.
13 size_t n = 0;
14 char c;
15 while ((c = getchar()) != '\n') {
16 if (c == '\b') {
17 readline_buf[n] = '\0';
18 n--;
19 } else if (c == EOF || c == '\0') {
20 return (StringView){ .start = NULL, .n = 0 };
21 } else if ((c >= ' ' && c <= '~') && n < RL_BUF_SIZE) {
22 readline_buf[n] = c;
23 n++;
24 }
25 }
26
27 StringView sv = (StringView){
28 .start = (char *)&readline_buf,
29 .n = n,
30 };
31 return sv;
32}
diff --git a/src/treewalk/read_line.h b/src/treewalk/read_line.h
deleted file mode 100644
index 160bce0..0000000
--- a/src/treewalk/read_line.h
+++ /dev/null
@@ -1,10 +0,0 @@
1#ifndef BDL_READ_LINE_H
2#define BDL_READ_LINE_H
3
4#include "string_view.h"
5
6StringView read_line(void);
7
8#define RL_BUF_SIZE 1024
9
10#endif // BDL_READ_LINE_H
diff --git a/src/treewalk/singletons.c b/src/treewalk/singletons.c
deleted file mode 100644
index eb9c397..0000000
--- a/src/treewalk/singletons.c
+++ /dev/null
@@ -1,17 +0,0 @@
1#include "environment.h"
2#include "gc.h"
3#include "objects.h"
4
5// Global garbage collector singleton.
6static GC gc;
7
8// Special singleton Objects.
9static Object *obj_nil;
10static Object *obj_true;
11static Object *obj_false;
12static Object *obj_err;
13static Object *obj_quote;
14static Object *proc_if;
15
16// Global environment.
17static Environment *global_env;
diff --git a/src/treewalk/string_view.c b/src/treewalk/string_view.c
deleted file mode 100644
index 39fabe9..0000000
--- a/src/treewalk/string_view.c
+++ /dev/null
@@ -1,40 +0,0 @@
1#include "string_view.h"
2
3char
4sv_next(StringView *sv) {
5 if (sv->n == 0) {
6 return '\0';
7 }
8 char c = sv->start[0];
9 sv->start++;
10 sv->n--;
11 return c;
12}
13
14char
15sv_peek(const StringView *sv) {
16 if (sv->n == 0) {
17 return '\0';
18 }
19 return sv->start[0];
20}
21
22bool
23sv_equal(const StringView *a, const StringView *b) {
24 if (a->n != b->n) {
25 return false;
26 }
27 for (size_t i = 0; i < a->n; i++) {
28 if (a->start[i] != b->start[i]) {
29 return false;
30 }
31 }
32 return true;
33}
34
35void
36sv_write(const StringView *sv, FILE *file) {
37 for (size_t i = 0; i < sv->n; i++) {
38 putc(sv->start[i], file);
39 }
40}
diff --git a/src/treewalk/string_view.h b/src/treewalk/string_view.h
deleted file mode 100644
index 42273ab..0000000
--- a/src/treewalk/string_view.h
+++ /dev/null
@@ -1,21 +0,0 @@
1#ifndef BDL_STRINGVIEW_H
2#define BDL_STRINGVIEW_H
3
4typedef struct StringView {
5 char *start;
6 size_t n;
7} StringView;
8
9// Consume a character in the stream.
10char sv_next(StringView *sv);
11
12// Check what is the current character in the stream.
13char sv_peek(const StringView *sv);
14
15// Compare if the arguments are the same.
16bool sv_equal(const StringView *a, const StringView *b);
17
18// Write a character to the given output stream.
19void sv_write(const StringView *sv, FILE *file);
20
21#endif // BDL_STRINGVIEW_H
generated by cgit v1.2.1 (git 2.18.0) at 2024-06-26 15:35:58 +0000