diff options
Diffstat (limited to 'src/bootstrap')
-rw-r--r-- | src/bootstrap/darray.h | 78 | ||||
-rw-r--r-- | src/bootstrap/environment.c | 72 | ||||
-rw-r--r-- | src/bootstrap/environment.h | 27 | ||||
-rw-r--r-- | src/bootstrap/errors.c | 29 | ||||
-rw-r--r-- | src/bootstrap/errors.h | 38 | ||||
-rw-r--r-- | src/bootstrap/gc.c | 199 | ||||
-rw-r--r-- | src/bootstrap/gc.h | 46 | ||||
-rw-r--r-- | src/bootstrap/hashtable.h | 191 | ||||
-rw-r--r-- | src/bootstrap/lexer.c | 257 | ||||
-rw-r--r-- | src/bootstrap/lexer.h | 57 | ||||
-rwxr-xr-x | src/bootstrap/main.c | 288 | ||||
-rw-r--r-- | src/bootstrap/objects.c | 141 | ||||
-rw-r--r-- | src/bootstrap/objects.h | 75 | ||||
-rw-r--r-- | src/bootstrap/parser.c | 139 | ||||
-rw-r--r-- | src/bootstrap/parser.h | 22 | ||||
-rw-r--r-- | src/bootstrap/primitives.c | 918 | ||||
-rw-r--r-- | src/bootstrap/primitives.h | 60 | ||||
-rw-r--r-- | src/bootstrap/read_line.c | 32 | ||||
-rw-r--r-- | src/bootstrap/read_line.h | 10 | ||||
-rw-r--r-- | src/bootstrap/singletons.c | 17 | ||||
-rw-r--r-- | src/bootstrap/string_view.c | 40 | ||||
-rw-r--r-- | src/bootstrap/string_view.h | 21 |
22 files changed, 0 insertions, 2757 deletions
diff --git a/src/bootstrap/darray.h b/src/bootstrap/darray.h deleted file mode 100644 index db6234d..0000000 --- a/src/bootstrap/darray.h +++ /dev/null | |||
@@ -1,78 +0,0 @@ | |||
1 | #ifndef BDL_DARRAY_H | ||
2 | #define BDL_DARRAY_H | ||
3 | |||
4 | #include <string.h> | ||
5 | |||
6 | typedef 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 | |||
35 | static 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 | |||
44 | static 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 | |||
59 | static inline | ||
60 | char * _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/bootstrap/environment.c b/src/bootstrap/environment.c deleted file mode 100644 index dd4a648..0000000 --- a/src/bootstrap/environment.c +++ /dev/null | |||
@@ -1,72 +0,0 @@ | |||
1 | #include "environment.h" | ||
2 | #include "gc.h" | ||
3 | #include "errors.h" | ||
4 | |||
5 | Environment * | ||
6 | env_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 | |||
14 | void | ||
15 | env_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 | |||
28 | Object * | ||
29 | env_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 | |||
40 | Object * | ||
41 | env_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 | |||
57 | void | ||
58 | env_add_or_update_current(Environment *env, Object *symbol, Object *value) { | ||
59 | ht_insert(env->table, symbol, value); | ||
60 | } | ||
61 | |||
62 | Environment * | ||
63 | env_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/bootstrap/environment.h b/src/bootstrap/environment.h deleted file mode 100644 index 5ee21ad..0000000 --- a/src/bootstrap/environment.h +++ /dev/null | |||
@@ -1,27 +0,0 @@ | |||
1 | #ifndef BDL_ENVIRONMENT_H | ||
2 | #define BDL_ENVIRONMENT_H | ||
3 | |||
4 | #include "objects.h" | ||
5 | |||
6 | typedef struct Environment { | ||
7 | struct Environment *parent; | ||
8 | HashTable *table; | ||
9 | bool marked; | ||
10 | } Environment; | ||
11 | |||
12 | Environment * env_create(Environment *parent); | ||
13 | void env_add_symbol(Environment *env, Object *symbol, Object *value); | ||
14 | Object * env_lookup(Environment *env, Object *symbol); | ||
15 | Object * env_update(Environment *env, Object *symbol, Object *value); | ||
16 | ssize_t env_index_current(Environment *env, Object *symbol); | ||
17 | void env_add_or_update_current(Environment *env, Object *symbol, Object *value); | ||
18 | Environment * 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/bootstrap/errors.c b/src/bootstrap/errors.c deleted file mode 100644 index d957cfa..0000000 --- a/src/bootstrap/errors.c +++ /dev/null | |||
@@ -1,29 +0,0 @@ | |||
1 | #include "errors.h" | ||
2 | |||
3 | static 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 | |||
20 | static Error errors[ERR_MAX_NUMBER]; | ||
21 | static size_t errors_n = 0; | ||
22 | static bool supress_errors = false; | ||
23 | |||
24 | void | ||
25 | error_push(Error error) { | ||
26 | if (errors_n < ERR_MAX_NUMBER) { | ||
27 | errors[errors_n++] = error; | ||
28 | } | ||
29 | } | ||
diff --git a/src/bootstrap/errors.h b/src/bootstrap/errors.h deleted file mode 100644 index 7916f4a..0000000 --- a/src/bootstrap/errors.h +++ /dev/null | |||
@@ -1,38 +0,0 @@ | |||
1 | #ifndef BDL_ERRORS_H | ||
2 | #define BDL_ERRORS_H | ||
3 | |||
4 | typedef enum ErrorType { | ||
5 | ERR_TYPE_LEXER, | ||
6 | ERR_TYPE_PARSER, | ||
7 | ERR_TYPE_RUNTIME, | ||
8 | } ErrorType; | ||
9 | |||
10 | typedef 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 | |||
27 | typedef struct Error { | ||
28 | ErrorType type; | ||
29 | ErrorValue value; | ||
30 | size_t line; | ||
31 | size_t col; | ||
32 | } Error; | ||
33 | |||
34 | void error_push(Error error); | ||
35 | |||
36 | #define ERR_MAX_NUMBER 16 | ||
37 | |||
38 | #endif // BDL_ERRORS_H | ||
diff --git a/src/bootstrap/gc.c b/src/bootstrap/gc.c deleted file mode 100644 index 358a07e..0000000 --- a/src/bootstrap/gc.c +++ /dev/null | |||
@@ -1,199 +0,0 @@ | |||
1 | #include "gc.h" | ||
2 | |||
3 | Environment * | ||
4 | alloc_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 | |||
19 | void | ||
20 | push_root(Object *obj) { | ||
21 | array_push(gc.roots, obj); | ||
22 | } | ||
23 | |||
24 | Object * | ||
25 | pop_root(void) { | ||
26 | return array_pop(gc.roots); | ||
27 | } | ||
28 | |||
29 | void | ||
30 | push_active_env(Environment *env) { | ||
31 | array_push(gc.active_envs, env); | ||
32 | } | ||
33 | |||
34 | Environment * | ||
35 | pop_active_env(void) { | ||
36 | return array_pop(gc.active_envs); | ||
37 | } | ||
38 | |||
39 | void | ||
40 | gc_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 | |||
60 | void | ||
61 | mark_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 | |||
75 | void | ||
76 | mark_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 | |||
92 | void | ||
93 | mark_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 | |||
132 | void | ||
133 | dump_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 | |||
172 | Object * | ||
173 | alloc_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/bootstrap/gc.h b/src/bootstrap/gc.h deleted file mode 100644 index 9ad1615..0000000 --- a/src/bootstrap/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 | |||
7 | typedef struct FreeList { | ||
8 | size_t *offsets; | ||
9 | size_t position; | ||
10 | } FreeList; | ||
11 | |||
12 | typedef 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 | |||
21 | void gc_init(void); | ||
22 | |||
23 | // Allocation functions for objects and environments. | ||
24 | Object * alloc_object(ObjectType type); | ||
25 | Environment * alloc_env(void); | ||
26 | |||
27 | // Root and environment protector functions. | ||
28 | void push_root(Object *obj); | ||
29 | Object * pop_root(void); | ||
30 | void push_active_env(Environment *env); | ||
31 | Environment * pop_active_env(void); | ||
32 | |||
33 | // Mark and sweep algorithm functions. | ||
34 | void mark_environment(Environment *env); | ||
35 | void mark_obj(Object *obj); | ||
36 | void mark_and_sweep(void); | ||
37 | |||
38 | // Debugging function to print out the contentes of some GC fields. | ||
39 | void 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/bootstrap/hashtable.h b/src/bootstrap/hashtable.h deleted file mode 100644 index 8f210e3..0000000 --- a/src/bootstrap/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 | |||
14 | typedef struct HashTablePair { | ||
15 | Object *key; | ||
16 | Object *value; | ||
17 | } HashTablePair; | ||
18 | |||
19 | typedef 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. | ||
33 | static 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. | ||
45 | static inline uint64_t | ||
46 | _fibonacci_hash(uint64_t hash, size_t shift_amount) { | ||
47 | return (hash * UINT64_C(11400714819323198485)) >> (64 - shift_amount); | ||
48 | } | ||
49 | |||
50 | uint64_t | ||
51 | ht_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 | |||
76 | static inline float | ||
77 | ht_load_factor(const HashTable *table) { | ||
78 | return (float)array_size(table->pairs) / (float)array_cap(table->pairs); | ||
79 | } | ||
80 | |||
81 | HashTable * | ||
82 | ht_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 | |||
93 | void | ||
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 | |||
119 | void | ||
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 | |||
145 | void | ||
146 | ht_insert(HashTable *table, const Object *key, const Object *value) { | ||
147 | _ht_maybe_grow(table); | ||
148 | _ht_insert(table, key, value); | ||
149 | return; | ||
150 | } | ||
151 | |||
152 | Object * | ||
153 | ht_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 | |||
179 | void | ||
180 | ht_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/bootstrap/lexer.c b/src/bootstrap/lexer.c deleted file mode 100644 index 38ca37c..0000000 --- a/src/bootstrap/lexer.c +++ /dev/null | |||
@@ -1,257 +0,0 @@ | |||
1 | #include "lexer.h" | ||
2 | |||
3 | void | ||
4 | print_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 | |||
47 | char | ||
48 | scan_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 | |||
60 | char | ||
61 | scan_peek(const Scanner *scanner) { | ||
62 | return sv_peek(&scanner->current); | ||
63 | } | ||
64 | |||
65 | bool | ||
66 | scan_has_next(const Scanner *scanner) { | ||
67 | return scanner->current.n != 0; | ||
68 | } | ||
69 | |||
70 | void | ||
71 | skip_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 | |||
90 | bool | ||
91 | is_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 | |||
112 | TokenType | ||
113 | find_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 | |||
137 | Token * | ||
138 | tokenize(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/bootstrap/lexer.h b/src/bootstrap/lexer.h deleted file mode 100644 index 2b2789f..0000000 --- a/src/bootstrap/lexer.h +++ /dev/null | |||
@@ -1,57 +0,0 @@ | |||
1 | #ifndef BDL_LEXER_H | ||
2 | #define BDL_LEXER_H | ||
3 | |||
4 | typedef 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 | |||
18 | typedef struct Token { | ||
19 | TokenType type; | ||
20 | StringView value; | ||
21 | size_t line; | ||
22 | size_t column; | ||
23 | } Token; | ||
24 | |||
25 | typedef 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. | ||
33 | void print_token(Token tok); | ||
34 | |||
35 | // Same functionality as the ScanView pairs, but keeping track of line and | ||
36 | // column numbers. | ||
37 | char scan_next(Scanner *scanner); | ||
38 | char scan_peek(const Scanner *scanner); | ||
39 | |||
40 | // Check if the current scanner still have characters left. | ||
41 | bool scan_has_next(const Scanner *scanner); | ||
42 | |||
43 | // Advance the scanner until we ran out of whitespace. | ||
44 | void skip_whitespace(Scanner *scanner); | ||
45 | |||
46 | // Check if a given character is a delimiter. | ||
47 | bool is_delimiter(char c); | ||
48 | |||
49 | // Extract the token type from the current string. | ||
50 | TokenType find_primitive_type(const StringView value); | ||
51 | |||
52 | // Generate a list of tokens from the given string. | ||
53 | Token * tokenize(const StringView *sv); | ||
54 | |||
55 | #define TOK_BUF_CAP 256 | ||
56 | |||
57 | #endif // BDL_LEXER_H | ||
diff --git a/src/bootstrap/main.c b/src/bootstrap/main.c deleted file mode 100755 index a5888fd..0000000 --- a/src/bootstrap/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 | |||
24 | void | ||
25 | init(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 | |||
96 | void | ||
97 | process_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 | |||
135 | void | ||
136 | run_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 | |||
165 | void | ||
166 | run_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 | |||
208 | void | ||
209 | run_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 | |||
247 | void | ||
248 | print_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 | |||
255 | int | ||
256 | main(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/bootstrap/objects.c b/src/bootstrap/objects.c deleted file mode 100644 index c71bc40..0000000 --- a/src/bootstrap/objects.c +++ /dev/null | |||
@@ -1,141 +0,0 @@ | |||
1 | #include "gc.h" | ||
2 | #include "objects.h" | ||
3 | |||
4 | // | ||
5 | // Constructors. | ||
6 | // | ||
7 | |||
8 | Object * | ||
9 | make_fixnum(ssize_t num) { | ||
10 | Object *obj = alloc_object(OBJ_TYPE_FIXNUM); | ||
11 | obj->fixnum = num; | ||
12 | return obj; | ||
13 | } | ||
14 | |||
15 | Object * | ||
16 | make_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 | |||
22 | Object * | ||
23 | make_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 | |||
30 | Object * | ||
31 | make_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 | |||
39 | Object * | ||
40 | make_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 | |||
47 | void | ||
48 | append_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 | |||
55 | void | ||
56 | display_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 | |||
69 | void | ||
70 | display(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 | |||
107 | bool | ||
108 | obj_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/bootstrap/objects.h b/src/bootstrap/objects.h deleted file mode 100644 index ed623eb..0000000 --- a/src/bootstrap/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 | |||
6 | typedef 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 | |||
18 | struct Environment; | ||
19 | |||
20 | typedef 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. | ||
56 | Object * make_fixnum(ssize_t num); | ||
57 | Object * make_procedure(Object *(*proc)(struct Environment *, Object *args)); | ||
58 | Object * make_pair(Object *car, Object *cdr); | ||
59 | Object * make_symbol(StringView sv); | ||
60 | Object * make_string(void); | ||
61 | void append_string(Object *obj, const StringView sv); | ||
62 | |||
63 | // Object representation. | ||
64 | void display(Object *root); | ||
65 | void display_pair(Object *root); | ||
66 | |||
67 | // Object comparison. | ||
68 | bool 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/bootstrap/parser.c b/src/bootstrap/parser.c deleted file mode 100644 index a2f0f71..0000000 --- a/src/bootstrap/parser.c +++ /dev/null | |||
@@ -1,139 +0,0 @@ | |||
1 | #include "parser.h" | ||
2 | |||
3 | Token | ||
4 | peek_token(const Visitor *visitor) { | ||
5 | return visitor->tokens[visitor->current]; | ||
6 | } | ||
7 | |||
8 | Token | ||
9 | next_token(Visitor *visitor) { | ||
10 | return visitor->tokens[visitor->current++]; | ||
11 | } | ||
12 | |||
13 | bool | ||
14 | has_next_token(const Visitor *visitor) { | ||
15 | return visitor->current < array_size(visitor->tokens); | ||
16 | } | ||
17 | |||
18 | Object * | ||
19 | parse_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 | |||
36 | Object * | ||
37 | parse_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 | |||
69 | Object * | ||
70 | parse_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/bootstrap/parser.h b/src/bootstrap/parser.h deleted file mode 100644 index 3834c75..0000000 --- a/src/bootstrap/parser.h +++ /dev/null | |||
@@ -1,22 +0,0 @@ | |||
1 | #ifndef BDL_PARSER_H | ||
2 | #define BDL_PARSER_H | ||
3 | |||
4 | typedef struct Visitor { | ||
5 | Token *tokens; | ||
6 | size_t current; | ||
7 | } Visitor; | ||
8 | |||
9 | // Mimics the functionality in the Scanner functions, but for entire tokens. | ||
10 | Token next_token(Visitor *visitor); | ||
11 | Token peek_token(const Visitor *visitor); | ||
12 | bool has_next_token(const Visitor *visitor); | ||
13 | |||
14 | // Parse a token into a fixnum object. | ||
15 | Object * 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. | ||
19 | Object * parse_list(Visitor *vs); | ||
20 | Object * parse_tree(Visitor *vs); | ||
21 | |||
22 | #endif // BDL_PARSER_H | ||
diff --git a/src/bootstrap/primitives.c b/src/bootstrap/primitives.c deleted file mode 100644 index 8b0d407..0000000 --- a/src/bootstrap/primitives.c +++ /dev/null | |||
@@ -1,918 +0,0 @@ | |||
1 | #include "primitives.h" | ||
2 | |||
3 | Object * | ||
4 | eval(Environment *env, Object *root) { | ||
5 | Object* lambda = NULL; | ||
6 | Object* args = NULL; | ||
7 | Object* ret = NULL; | ||
8 | bool recursion_active = false; | ||
9 | eval_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 | |||
96 | eval_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 | |||
178 | eval_success: | ||
179 | if (recursion_active) { | ||
180 | // Remove stack protector. | ||
181 | pop_active_env(); | ||
182 | } | ||
183 | return ret; | ||
184 | } | ||
185 | |||
186 | Object * | ||
187 | proc_quote(Environment *env, Object *obj) { | ||
188 | (void)env; | ||
189 | return obj->car; | ||
190 | } | ||
191 | |||
192 | static inline Object * | ||
193 | extract_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 | |||
219 | Object * | ||
220 | proc_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 | |||
232 | Object * | ||
233 | proc_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 | |||
245 | Object * | ||
246 | proc_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 | |||
258 | Object * | ||
259 | proc_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 | |||
278 | Object * | ||
279 | proc_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 | |||
302 | Object * | ||
303 | proc_display(Environment *env, Object *obj) { | ||
304 | display(eval(env, obj->car)); | ||
305 | return obj_nil; | ||
306 | } | ||
307 | |||
308 | Object * | ||
309 | proc_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 | |||
332 | Object * | ||
333 | proc_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 | |||
344 | Object * | ||
345 | proc_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 | |||
360 | Object * | ||
361 | proc_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 | |||
376 | Object * | ||
377 | proc_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 | |||
392 | Object * | ||
393 | proc_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 | |||
408 | Object * | ||
409 | proc_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 | |||
424 | Object * | ||
425 | proc_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 | |||
440 | Object * | ||
441 | proc_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 | |||
456 | Object * | ||
457 | proc_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 | |||
476 | Object * | ||
477 | proc_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 | |||
492 | Object * | ||
493 | proc_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 | |||
503 | Object * | ||
504 | proc_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 | |||
514 | Object * | ||
515 | proc_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 | |||
546 | Object * | ||
547 | proc_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 | |||
562 | Object * | ||
563 | proc_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 | |||
578 | Object * | ||
579 | proc_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 | |||
594 | Object * | ||
595 | proc_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 | |||
610 | Object * | ||
611 | proc_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 | |||
630 | Object * | ||
631 | proc_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 | |||
653 | Object * | ||
654 | proc_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 | |||
676 | Object * | ||
677 | proc_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 | |||
701 | Object * | ||
702 | proc_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 | |||
735 | Object * | ||
736 | proc_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 | |||
759 | Object * | ||
760 | proc_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 | |||
787 | Object * | ||
788 | proc_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 | |||
814 | Object * | ||
815 | proc_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 | |||
839 | Object * | ||
840 | proc_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 | |||
879 | Object * | ||
880 | proc_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 | |||
895 | Object * | ||
896 | proc_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/bootstrap/primitives.h b/src/bootstrap/primitives.h deleted file mode 100644 index f874b17..0000000 --- a/src/bootstrap/primitives.h +++ /dev/null | |||
@@ -1,60 +0,0 @@ | |||
1 | #ifndef BDL_PRIMITIVES_H | ||
2 | #define BDL_PRIMITIVES_H | ||
3 | |||
4 | // Function evaluation. | ||
5 | Object * eval(Environment *env, Object *root); | ||
6 | |||
7 | // Evaluation functions. | ||
8 | Object * proc_quote(Environment *env, Object *obj); | ||
9 | Object * proc_eval(Environment *env, Object *obj); | ||
10 | |||
11 | // Arithmetic. | ||
12 | Object * proc_sum(Environment *env, Object *obj); | ||
13 | Object * proc_sub(Environment *env, Object *obj); | ||
14 | Object * proc_mul(Environment *env, Object *obj); | ||
15 | Object * proc_div(Environment *env, Object *obj); | ||
16 | Object * proc_mod(Environment *env, Object *obj); | ||
17 | |||
18 | // Printing. | ||
19 | Object * proc_display(Environment *env, Object *obj); | ||
20 | Object * proc_print(Environment *env, Object *obj); | ||
21 | Object * proc_newline(Environment *env, Object *obj); | ||
22 | |||
23 | // Type checking. | ||
24 | Object * proc_is_boolean(Environment *env, Object *obj); | ||
25 | Object * proc_is_nil(Environment *env, Object *obj); | ||
26 | Object * proc_is_symbol(Environment *env, Object *obj); | ||
27 | Object * proc_is_string(Environment *env, Object *obj); | ||
28 | Object * proc_is_fixnum(Environment *env, Object *obj); | ||
29 | Object * proc_is_pair(Environment *env, Object *obj); | ||
30 | Object * proc_is_procedure(Environment *env, Object *obj); | ||
31 | Object * proc_is_error(Environment *env, Object *obj); | ||
32 | |||
33 | // Logical operations. | ||
34 | Object * proc_not(Environment *env, Object *obj); | ||
35 | Object * proc_and(Environment *env, Object *obj); | ||
36 | Object * proc_or(Environment *env, Object *obj); | ||
37 | Object * proc_cond(Environment *env, Object *obj); | ||
38 | Object * proc_num_less_than(Environment *env, Object *obj); | ||
39 | Object * proc_num_greater_than(Environment *env, Object *obj); | ||
40 | Object * proc_num_lesseq_than(Environment *env, Object *obj); | ||
41 | Object * proc_num_greatereq_than(Environment *env, Object *obj); | ||
42 | Object * proc_num_equal(Environment *env, Object *obj); | ||
43 | Object * proc_equal(Environment *env, Object *obj); | ||
44 | |||
45 | // List operations. | ||
46 | Object * proc_car(Environment *env, Object *obj); | ||
47 | Object * proc_cdr(Environment *env, Object *obj); | ||
48 | Object * proc_cons(Environment *env, Object *obj); | ||
49 | Object * proc_list(Environment *env, Object *obj); | ||
50 | |||
51 | // Environment/variable manipulation. | ||
52 | Object * proc_define(Environment *env, Object *obj); | ||
53 | Object * proc_set(Environment *env, Object *obj); | ||
54 | Object * proc_lambda(Environment *env, Object *obj); | ||
55 | Object * proc_fun(Environment *env, Object *obj); | ||
56 | |||
57 | // Runtinme configuration. | ||
58 | Object * proc_supress_errors(Environment *env, Object *obj); | ||
59 | |||
60 | #endif // BDL_PRIMITIVES_H | ||
diff --git a/src/bootstrap/read_line.c b/src/bootstrap/read_line.c deleted file mode 100644 index 03146ad..0000000 --- a/src/bootstrap/read_line.c +++ /dev/null | |||
@@ -1,32 +0,0 @@ | |||
1 | #include "read_line.h" | ||
2 | |||
3 | static char readline_buf[RL_BUF_SIZE]; | ||
4 | |||
5 | StringView | ||
6 | read_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/bootstrap/read_line.h b/src/bootstrap/read_line.h deleted file mode 100644 index 160bce0..0000000 --- a/src/bootstrap/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 | |||
6 | StringView read_line(void); | ||
7 | |||
8 | #define RL_BUF_SIZE 1024 | ||
9 | |||
10 | #endif // BDL_READ_LINE_H | ||
diff --git a/src/bootstrap/singletons.c b/src/bootstrap/singletons.c deleted file mode 100644 index eb9c397..0000000 --- a/src/bootstrap/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. | ||
6 | static GC gc; | ||
7 | |||
8 | // Special singleton Objects. | ||
9 | static Object *obj_nil; | ||
10 | static Object *obj_true; | ||
11 | static Object *obj_false; | ||
12 | static Object *obj_err; | ||
13 | static Object *obj_quote; | ||
14 | static Object *proc_if; | ||
15 | |||
16 | // Global environment. | ||
17 | static Environment *global_env; | ||
diff --git a/src/bootstrap/string_view.c b/src/bootstrap/string_view.c deleted file mode 100644 index 39fabe9..0000000 --- a/src/bootstrap/string_view.c +++ /dev/null | |||
@@ -1,40 +0,0 @@ | |||
1 | #include "string_view.h" | ||
2 | |||
3 | char | ||
4 | sv_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 | |||
14 | char | ||
15 | sv_peek(const StringView *sv) { | ||
16 | if (sv->n == 0) { | ||
17 | return '\0'; | ||
18 | } | ||
19 | return sv->start[0]; | ||
20 | } | ||
21 | |||
22 | bool | ||
23 | sv_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 | |||
35 | void | ||
36 | sv_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/bootstrap/string_view.h b/src/bootstrap/string_view.h deleted file mode 100644 index 42273ab..0000000 --- a/src/bootstrap/string_view.h +++ /dev/null | |||
@@ -1,21 +0,0 @@ | |||
1 | #ifndef BDL_STRINGVIEW_H | ||
2 | #define BDL_STRINGVIEW_H | ||
3 | |||
4 | typedef struct StringView { | ||
5 | char *start; | ||
6 | size_t n; | ||
7 | } StringView; | ||
8 | |||
9 | // Consume a character in the stream. | ||
10 | char sv_next(StringView *sv); | ||
11 | |||
12 | // Check what is the current character in the stream. | ||
13 | char sv_peek(const StringView *sv); | ||
14 | |||
15 | // Compare if the arguments are the same. | ||
16 | bool sv_equal(const StringView *a, const StringView *b); | ||
17 | |||
18 | // Write a character to the given output stream. | ||
19 | void sv_write(const StringView *sv, FILE *file); | ||
20 | |||
21 | #endif // BDL_STRINGVIEW_H | ||