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

Change to using RefCount

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-10 02:57:48 -07:00
parent a38fef7857
commit 994827431c
6 changed files with 1110 additions and 779 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
CMakeLists.txt
View File

@ -1,10 +1,23 @@
cmake_minimum_required(VERSION 3.10) cmake_minimum_required(VERSION 3.10)
set(CMAKE_C_STANDARD 11) set(CMAKE_C_STANDARD 11)
set(CMAKE_EXPORT_COMPILE_COMMANDS TRUE)
project(simple-lisp) project(
simple-lisp
VERSION 1.0
LANGUAGES C)
add_compile_options(-Wall -fsanitize=address,leak,undefined) include(FetchContent)
FetchContent_Declare(
refcount
GIT_REPOSITORY https://git.zander.im/Zander671/refcount.git
GIT_TAG ae7b645b7a4919c20c75f68348347038601229f7)
FetchContent_MakeAvailable(refcount)
add_compile_options(-fsanitize=address,leak,undefined)
add_link_options(-fsanitize=address,leak,undefined) add_link_options(-fsanitize=address,leak,undefined)
add_executable(simple-lisp src/main.c src/lisp.c src/read.c) add_executable(simple-lisp src/main.c src/lisp.c src/read.c)
target_link_libraries(simple-lisp PUBLIC refcount)
target_compile_options(simple-lisp PRIVATE -Wall -Wpedantic)

1418
src/lisp.c
View File

File diff suppressed because it is too large Load Diff

172
src/lisp.h
View File

@ -1,6 +1,7 @@
#ifndef INCLUDED_LISP_H #ifndef INCLUDED_LISP_H
#define INCLUDED_LISP_H #define INCLUDED_LISP_H
#include <refcount/refcount.h>
#include <setjmp.h> #include <setjmp.h>
#include <stdarg.h> #include <stdarg.h>
#include <stdbool.h> #include <stdbool.h>
@ -10,7 +11,7 @@
#include <stdlib.h> #include <stdlib.h>
#include <stdnoreturn.h> #include <stdnoreturn.h>
#if __has_attribute(format) #if defined(__has_attribute) && __has_attribute(format)
# define PRINTF_FORMAT(first, second) \ # define PRINTF_FORMAT(first, second) \
__attribute__((format(printf, first, second))) __attribute__((format(printf, first, second)))
#else #else
@ -41,9 +42,7 @@ extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES];
#define LISP_OBJECT_HEADER \ #define LISP_OBJECT_HEADER \
LispType type; \ LispType type; \
void *gc_root; \ RefcountEntry refcount
ptrdiff_t ref_count; \
bool finalizing;
typedef struct { typedef struct {
LISP_OBJECT_HEADER; LISP_OBJECT_HEADER;
@ -91,6 +90,7 @@ typedef struct {
LispVal **data; LispVal **data;
size_t length; size_t length;
bool is_static;
} LispVector; } LispVector;
struct OptArgDesc { struct OptArgDesc {
@ -102,6 +102,8 @@ struct OptArgDesc {
void free_opt_arg_desc(void *obj); void free_opt_arg_desc(void *obj);
typedef void (*lisp_function_ptr_t)(void);
typedef struct { typedef struct {
LISP_OBJECT_HEADER; LISP_OBJECT_HEADER;
@ -118,7 +120,7 @@ typedef struct {
bool allow_other_keys; bool allow_other_keys;
LispVal *rest_arg; LispVal *rest_arg;
union { union {
void *builtin; lisp_function_ptr_t builtin;
LispVal *body; LispVal *body;
}; };
@ -211,36 +213,33 @@ inline static bool NUMBERP(LispVal *v) {
#define DEF_STATIC_STRING(name, value) \ #define DEF_STATIC_STRING(name, value) \
static LispString name = { \ static LispString name = { \
.type = TYPE_STRING, \ .type = TYPE_STRING, \
.ref_count = -1, \
.data = value, \ .data = value, \
.length = sizeof(value) - 1, \ .length = sizeof(value) - 1, \
.is_static = true, \ .is_static = true, \
}; }
#define DEF_STATIC_SYMBOL(c_name, lisp_name) \ #define DEF_STATIC_SYMBOL(c_name, lisp_name) \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \ DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
static LispSymbol _Q##c_name = { \ static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \ .type = TYPE_SYMBOL, \
.ref_count = -1, \
.name = &_Q##c_name##_name, \ .name = &_Q##c_name##_name, \
.plist = Qnil, \ .plist = Qnil, \
.function = Qunbound, \ .function = Qunbound, \
.value = Qunbound, \ .value = Qunbound, \
.is_constant = false, \ .is_constant = false, \
}; \ }; \
LispVal *Q##c_name = LISPVAL(&_Q##c_name); LispVal *Q##c_name = LISPVAL(&_Q##c_name)
#define DECLARE_FUNCTION(c_name, args) \ #define DECLARE_FUNCTION(c_name, args) \
LispVal *F##c_name args; \ LispVal *F##c_name args; \
extern LispVal *Q##c_name; extern LispVal *Q##c_name
// The args and doc fields are filled when the function is registered // The args and doc fields are filled when the function is registered
#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args) \ #define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args) \
LispVal *F##c_name c_args; \ LispVal *F##c_name c_args; \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \ DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
static LispFunction _Q##c_name##_function = { \ static LispFunction _Q##c_name##_function = { \
.type = TYPE_FUNCTION, \ .type = TYPE_FUNCTION, \
.ref_count = -1, \
.is_builtin = true, \ .is_builtin = true, \
.is_macro = macrop, \ .is_macro = macrop, \
.builtin = &F##c_name, \ .builtin = (void (*)(void)) & F##c_name, \
.doc = Qnil, \ .doc = Qnil, \
.args = Qnil, \ .args = Qnil, \
.rargs = Qnil, \ .rargs = Qnil, \
@ -251,7 +250,6 @@ inline static bool NUMBERP(LispVal *v) {
}; \ }; \
static LispSymbol _Q##c_name = { \ static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \ .type = TYPE_SYMBOL, \
.ref_count = -1, \
.name = &_Q##c_name##_name, \ .name = &_Q##c_name##_name, \
.plist = Qnil, \ .plist = Qnil, \
.value = Qunbound, \ .value = Qunbound, \
@ -284,12 +282,12 @@ inline static bool NUMBERP(LispVal *v) {
} \ } \
} \ } \
} }
#define FOREACH(var, list) \ #define FOREACH(var, list) \
for (LispVal *__foreach_cur = list, *var = Fhead(list); \ for (LispVal *__foreach_cur = list, *var = HEAD(list); \
!NILP(__foreach_cur); \ !NILP(__foreach_cur); \
__foreach_cur = Ftail(__foreach_cur), var = Fhead(__foreach_cur)) __foreach_cur = TAIL(__foreach_cur), var = HEAD(__foreach_cur))
#define FOREACH_TAIL(var, list) \ #define FOREACH_TAIL(var, list) \
for (LispVal *var = list; !NILP(var); var = Ftail(var)) for (LispVal *var = list; !NILP(var); var = TAIL(var))
// ############################# // #############################
// # Allocation and references # // # Allocation and references #
@ -300,16 +298,7 @@ void *lisp_malloc(size_t size);
void *lisp_realloc(void *old_ptr, size_t size); void *lisp_realloc(void *old_ptr, size_t size);
#define lisp_free free #define lisp_free free
void *lisp_ref(void *val); void garbage_collect(void);
void *lisp_float_ref(void *val);
void garbage_collect();
void *lisp_unref(void *val);
#define UNREF_INPLACE(variable) \
{ \
variable = lisp_unref(variable); \
}
void lisp_unref_double_ptr(void **val);
#define IGNORE_REF(val) (lisp_unref(lisp_ref(val)))
// ################ // ################
// # Constructors # // # Constructors #
@ -324,8 +313,8 @@ LispVal *make_lisp_integer(intmax_t value);
LispVal *make_lisp_float(long double value); LispVal *make_lisp_float(long double value);
LispVal *make_lisp_vector(LispVal **data, size_t length); LispVal *make_lisp_vector(LispVal **data, size_t length);
void set_function_args(LispFunction *func, LispVal *args); void set_function_args(LispFunction *func, LispVal *args);
LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv, LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body,
LispVal *body, bool is_macro); bool is_macro);
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn); LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
LispVal *make_user_pointer(void *data, void (*free_func)(void *)); LispVal *make_user_pointer(void *data, void (*free_func)(void *));
#define ALLOC_USERPTR(type, free_func) \ #define ALLOC_USERPTR(type, free_func) \
@ -336,7 +325,6 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *));
// ######################## // ########################
bool strings_equal_nocase(const char *s1, const char *s2, size_t n); bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
DECLARE_FUNCTION(type_of, (LispVal * obj));
DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail)); DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail));
DECLARE_FUNCTION(hash_string, (LispVal * obj)); DECLARE_FUNCTION(hash_string, (LispVal * obj));
DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2)); DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2));
@ -349,9 +337,9 @@ DECLARE_FUNCTION(hash_table_count, (LispVal * table));
LispVal *intern(const char *name, size_t length, bool take); LispVal *intern(const char *name, size_t length, bool take);
DECLARE_FUNCTION(intern, (LispVal * name)); DECLARE_FUNCTION(intern, (LispVal * name));
static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len) { static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len) {
LispVal *kn = lisp_ref(make_lisp_string(name, len, true, true)); LispVal *kn = make_lisp_string(name, len, true, true);
LispVal *retval = Fintern(kn); LispVal *retval = Fintern(kn);
lisp_unref(kn); refcount_unref(kn);
return retval; return retval;
} }
#define INTERN_STATIC(name) (_internal_INTERN_STATIC((name), sizeof(name) - 1)) #define INTERN_STATIC(name) (_internal_INTERN_STATIC((name), sizeof(name) - 1))
@ -372,6 +360,7 @@ static inline LispVal *const_list(int len, ...) {
} else { } else {
LispVal *new_end = Fpair(elt, Qnil); LispVal *new_end = Fpair(elt, Qnil);
Fsettail(end, new_end); Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end; end = new_end;
} }
} }
@ -388,6 +377,7 @@ static inline LispVal *make_list(size_t len, LispVal **vals) {
} else { } else {
LispVal *new_end = Fpair(vals[i], Qnil); LispVal *new_end = Fpair(vals[i], Qnil);
Fsettail(end, new_end); Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end; end = new_end;
} }
} }
@ -426,6 +416,7 @@ struct UnrefListData {
size_t len; size_t len;
}; };
void unref_free_list_double_ptr(void *ptr); void unref_free_list_double_ptr(void *ptr);
void unref_double_ptr(void *ptr);
void cancel_cleanup(void *handle); void cancel_cleanup(void *handle);
#define WITH_PUSH_FRAME(name, detail, inherit, body) \ #define WITH_PUSH_FRAME(name, detail, inherit, body) \
stack_enter(name, detail, inherit); \ stack_enter(name, detail, inherit); \
@ -433,17 +424,16 @@ void cancel_cleanup(void *handle);
body \ body \
} \ } \
stack_leave(); stack_leave();
#define WITH_CLEANUP(var, body) \ #define WITH_CLEANUP(var, body) \
lisp_ref(var); \ { \
{ \ void *__with_cleanup_cleanup = register_cleanup( \
void *__with_cleanup_cleanup = register_cleanup( \ (lisp_cleanup_func_t) & unref_double_ptr, &(var)); \
(lisp_cleanup_func_t) & lisp_unref_double_ptr, &(var)); \ {body}; \
{body}; \ cancel_cleanup(__with_cleanup_cleanup); \
cancel_cleanup(__with_cleanup_cleanup); \ refcount_unref(var); \
lisp_unref(var); \
} }
DECLARE_FUNCTION(backtrace, ()); DECLARE_FUNCTION(backtrace, (void) );
noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest)); noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
extern LispVal *Qshutdown_signal; extern LispVal *Qshutdown_signal;
@ -455,36 +445,35 @@ extern LispVal *Qvoid_function_error;
extern LispVal *Qcircular_error; extern LispVal *Qcircular_error;
extern LispVal *Qmalformed_lambda_list_error; extern LispVal *Qmalformed_lambda_list_error;
extern LispVal *Qargument_error; extern LispVal *Qargument_error;
extern LispVal *Qinvalid_function_error;
extern LispVal *Qno_applicable_method_error;
#define CHECK_TYPE(type, val) \ LispVal *predicate_for_type(LispType type);
if (TYPEOF(val) != type) { \ #define CHECK_TYPE(type, val) \
Fthrow(Qtype_error, Qnil); \ if (TYPEOF(val) != type) { \
LispVal *inner_list = const_list(1, predicate_for_type(type)); \
LispVal *args = const_list(2, inner_list, Ftype_of(LISPVAL(val))); \
refcount_unref(inner_list); \
Fthrow(Qtype_error, args); \
} }
struct StaticReference {
struct StaticReference *next;
LispVal *obj;
};
extern struct StaticReference *static_references;
void add_static_reference(LispVal *obj);
extern LispVal *Vobarray; extern LispVal *Vobarray;
#define REGISTER_SYMBOL(sym) \ #define REGISTER_SYMBOL(sym) \
{ \ { \
Fputhash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); \ refcount_init_static(Q##sym); \
add_static_reference(Q##sym); \ refcount_init_static(((LispSymbol *) Q##sym)->name); \
puthash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); \
} }
#define REGISTER_STATIC_FUNCTION(obj, args, docstr) \ #define REGISTER_STATIC_FUNCTION(obj, args, docstr) \
((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
{ \ { \
refcount_init_static(obj); \
((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
LispVal *src = STATIC_STRING(args); \ LispVal *src = STATIC_STRING(args); \
lisp_ref(src); \ LispVal *a = Fread(src); \
set_function_args((LispFunction *) (obj), Fread(src)); \ set_function_args((LispFunction *) (obj), a); \
lisp_unref(src); \ refcount_unref(src); \
add_static_reference(obj); \ refcount_unref(a); \
} }
#define REGISTER_FUNCTION(fn, args, docstr) \ #define REGISTER_FUNCTION(fn, args, docstr) \
REGISTER_SYMBOL(fn); \ REGISTER_SYMBOL(fn); \
@ -496,33 +485,84 @@ void register_static_function(LispVal *func);
extern LispVal *Qbackquote; extern LispVal *Qbackquote;
extern LispVal *Qcomma; extern LispVal *Qcomma;
extern LispVal *Qcomma_at;
DECLARE_FUNCTION(quote, (LispVal * form)); DECLARE_FUNCTION(quote, (LispVal * form));
DECLARE_FUNCTION(breakpoint, (LispVal * id));
DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve)); DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
DECLARE_FUNCTION(symbol_value, (LispVal * symbol)); DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv)); DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv));
DECLARE_FUNCTION(eval, (LispVal * form)); DECLARE_FUNCTION(eval, (LispVal * form));
DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest)); DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest));
DECLARE_FUNCTION(apply, (LispVal * function, LispVal *rest)); DECLARE_FUNCTION(apply, (LispVal * function, LispVal *rest));
DECLARE_FUNCTION(head, (LispVal * list)); DECLARE_FUNCTION(head, (LispVal * list));
DECLARE_FUNCTION(tail, (LispVal * list)); DECLARE_FUNCTION(tail, (LispVal * list));
noreturn DECLARE_FUNCTION(exit, (LispVal * code)); noreturn DECLARE_FUNCTION(exit, (LispVal * code));
DECLARE_FUNCTION(print, (LispVal * obj)); DECLARE_FUNCTION(print, (LispVal * obj));
DECLARE_FUNCTION(println, (LispVal * obj)); DECLARE_FUNCTION(println, (LispVal * obj));
DECLARE_FUNCTION(not, (LispVal * obj)); DECLARE_FUNCTION(not, (LispVal * obj));
DECLARE_FUNCTION(when, (LispVal * cond, LispVal *t));
DECLARE_FUNCTION(if, (LispVal * cond, LispVal *t, LispVal *nil)); DECLARE_FUNCTION(if, (LispVal * cond, LispVal *t, LispVal *nil));
DECLARE_FUNCTION(add, (LispVal * n1, LispVal *n2)); DECLARE_FUNCTION(add, (LispVal * args));
DECLARE_FUNCTION(setq, (LispVal * name, LispVal *value)); DECLARE_FUNCTION(sub, (LispVal * args));
DECLARE_FUNCTION(setq, (LispVal * args));
DECLARE_FUNCTION(progn, (LispVal * forms)); DECLARE_FUNCTION(progn, (LispVal * forms));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func)); DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body)); DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(defmacro, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
DECLARE_FUNCTION(while, (LispVal * condition, LispVal *body));
DECLARE_FUNCTION(make_symbol, (LispVal * name));
DECLARE_FUNCTION(macroexpand_1, (LispVal * form));
DECLARE_FUNCTION(stringp, (LispVal * val));
DECLARE_FUNCTION(symbolp, (LispVal * val));
DECLARE_FUNCTION(pairp, (LispVal * val));
DECLARE_FUNCTION(integerp, (LispVal * val));
DECLARE_FUNCTION(floatp, (LispVal * val));
DECLARE_FUNCTION(vectorp, (LispVal * val));
DECLARE_FUNCTION(functionp, (LispVal * val));
DECLARE_FUNCTION(macrop, (LispVal * val));
DECLARE_FUNCTION(hashtablep, (LispVal * val));
DECLARE_FUNCTION(user_pointer_p, (LispVal * val));
DECLARE_FUNCTION(atom, (LispVal * val));
DECLARE_FUNCTION(listp, (LispVal * val));
DECLARE_FUNCTION(keywordp, (LispVal * val));
DECLARE_FUNCTION(numberp, (LispVal * val));
DECLARE_FUNCTION(list_length, (LispVal * list));
DECLARE_FUNCTION(num_eq, (LispVal * n1, LispVal *n2));
DECLARE_FUNCTION(num_gt, (LispVal * n1, LispVal *n2));
DECLARE_FUNCTION(and, (LispVal * rest));
DECLARE_FUNCTION(or, (LispVal * rest));
DECLARE_FUNCTION(type_of, (LispVal * val));
DECLARE_FUNCTION(function_docstr, (LispVal * func));
void debug_dump(FILE *stream, void *obj, bool newline); void debug_dump(FILE *stream, void *obj, bool newline);
void debug_print_hashtable(FILE *stream, LispVal *table); void debug_print_hashtable(FILE *stream, LispVal *table);
void debug_print_tree(FILE *stream, void *obj);
extern LispVal *Qopt; extern LispVal *Qopt;
extern LispVal *Qkey; extern LispVal *Qkey;
extern LispVal *Qallow_other_keys; extern LispVal *Qallow_other_keys;
extern LispVal *Qrest; extern LispVal *Qrest;
// some internal functions
LispVal *puthash(LispVal *table, LispVal *key, LispVal *value);
LispVal *gethash(LispVal *table, LispVal *key, LispVal *def);
LispVal *remhash(LispVal *table, LispVal *key);
static inline LispVal *HEAD(LispVal *list) {
if (NILP(list)) {
return Qnil;
}
CHECK_TYPE(TYPE_PAIR, list);
return ((LispPair *) list)->head;
}
static inline LispVal *TAIL(LispVal *list) {
if (NILP(list)) {
return Qnil;
}
CHECK_TYPE(TYPE_PAIR, list);
return ((LispPair *) list)->tail;
}
#endif #endif

169
src/main.c
View File

@ -6,10 +6,9 @@ static int exit_status = 0;
LispVal *Ftoplevel_exit_handler(LispVal *except); LispVal *Ftoplevel_exit_handler(LispVal *except);
static LispFunction _Ftoplevel_exit_handler_function = { static LispFunction _Ftoplevel_exit_handler_function = {
.type = TYPE_FUNCTION, .type = TYPE_FUNCTION,
.ref_count = -1, .is_builtin = true,
.is_builtin = 1, .is_macro = false,
.is_macro = 0, .builtin = (lisp_function_ptr_t) &Ftoplevel_exit_handler,
.builtin = &Ftoplevel_exit_handler,
.args = Qnil, .args = Qnil,
.kwargs = Qnil, .kwargs = Qnil,
.rargs = Qnil, .rargs = Qnil,
@ -20,13 +19,13 @@ static LispFunction _Ftoplevel_exit_handler_function = {
#define Ftoplevel_exit_handler_function \ #define Ftoplevel_exit_handler_function \
LISPVAL(&_Ftoplevel_exit_handler_function) LISPVAL(&_Ftoplevel_exit_handler_function)
LispVal *Ftoplevel_exit_handler(LispVal *except) { LispVal *Ftoplevel_exit_handler(LispVal *except) {
LispVal *detail = Ftail(Fhead(except)); LispVal *detail = TAIL(HEAD(except));
if (NILP(detail) || NILP(Fhead(detail))) { if (NILP(detail) || NILP(HEAD(detail))) {
exit_status = 0; exit_status = 0;
} else if (!INTEGERP(Fhead(detail))) { } else if (!INTEGERP(HEAD(detail))) {
exit_status = 1; exit_status = 1;
} else { } else {
exit_status = ((LispInteger *) Fhead(detail))->value; exit_status = ((LispInteger *) HEAD(detail))->value;
} }
return Qnil; return Qnil;
} }
@ -34,10 +33,9 @@ LispVal *Ftoplevel_exit_handler(LispVal *except) {
LispVal *Ftoplevel_error_handler(LispVal *except); LispVal *Ftoplevel_error_handler(LispVal *except);
static LispFunction _Ftoplevel_error_handler_function = { static LispFunction _Ftoplevel_error_handler_function = {
.type = TYPE_FUNCTION, .type = TYPE_FUNCTION,
.ref_count = -1, .is_builtin = true,
.is_builtin = 1, .is_macro = false,
.is_macro = 0, .builtin = (lisp_function_ptr_t) &Ftoplevel_error_handler,
.builtin = &Ftoplevel_error_handler,
.args = Qnil, .args = Qnil,
.kwargs = Qnil, .kwargs = Qnil,
.lexenv = Qnil, .lexenv = Qnil,
@ -48,9 +46,9 @@ static LispFunction _Ftoplevel_error_handler_function = {
#define Ftoplevel_error_handler_function \ #define Ftoplevel_error_handler_function \
LISPVAL(&_Ftoplevel_error_handler_function) LISPVAL(&_Ftoplevel_error_handler_function)
LispVal *Ftoplevel_error_handler(LispVal *except) { LispVal *Ftoplevel_error_handler(LispVal *except) {
LispVal *type = Fhead(Fhead(except)); LispVal *type = HEAD(HEAD(except));
LispVal *detail = Ftail(Fhead(except)); LispVal *detail = TAIL(HEAD(except));
LispVal *backtrace = Fhead(Ftail(except)); LispVal *backtrace = HEAD(TAIL(except));
fprintf(stderr, "Caught signal of type "); fprintf(stderr, "Caught signal of type ");
debug_dump(stderr, type, true); debug_dump(stderr, type, true);
if (!NILP(detail)) { if (!NILP(detail)) {
@ -69,95 +67,56 @@ LispVal *Ftoplevel_error_handler(LispVal *except) {
DEF_STATIC_SYMBOL(toplevel_read, "toplevel-read"); DEF_STATIC_SYMBOL(toplevel_read, "toplevel-read");
int main(int argc, const char **argv) { int main(int argc, const char **argv) {
if (argc < 2) { /* if (argc < 2) { */
fprintf(stderr, "No input file!\n"); /* fprintf(stderr, "No input file!\n"); */
return 1; /* return 1; */
} /* } */
FILE *in = fopen(argv[1], "r"); /* FILE *in = fopen(argv[1], "r"); */
if (!in) { /* if (!in) { */
perror("fopen"); /* perror("fopen"); */
return 1; /* return 1; */
} /* } */
fseek(in, 0, SEEK_END); /* fseek(in, 0, SEEK_END); */
off_t file_len = ftello(in); /* off_t file_len = ftello(in); */
rewind(in); /* rewind(in); */
char buffer[file_len]; /* char buffer[file_len]; */
fread(buffer, 1, file_len, in); /* fread(buffer, 1, file_len, in); */
fclose(in); /* fclose(in); */
lisp_init(); lisp_init();
REGISTER_STATIC_FUNCTION(Ftoplevel_error_handler_function, "(e)", ""); /* refcount_init_static(Qtoplevel_read); */
REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", ""); /* REGISTER_STATIC_FUNCTION(Ftoplevel_error_handler_function, "(e)", ""); */
size_t pos = 0; /* REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", ""); */
// WITH_PUSH_FRAME(Qtoplevel, Qnil, false, { /* size_t pos = 0; */
// the_stack->hidden = true; /* WITH_PUSH_FRAME(Qtoplevel, Qnil, false, { */
// LispVal *err_var = INTERN_STATIC("err-var"); /* the_stack->hidden = true; */
// Fputhash( /* LispVal *err_var = INTERN_STATIC("err-var"); */
// the_stack->handlers, Qt, /* puthash( */
// // simply call the above function /* the_stack->handlers, Qt, */
// const_list(3, err_var, Ftoplevel_error_handler_function, /* // simply call the above function */
// err_var)); /* const_list(3, err_var, Ftoplevel_error_handler_function,
// Fputhash( * err_var)); */
// the_stack->handlers, Qshutdown_signal, /* puthash( */
// // simply call the above function /* the_stack->handlers, Qshutdown_signal, */
// const_list(3, err_var, Ftoplevel_exit_handler_function, /* // simply call the above function */
// err_var)); /* const_list(3, err_var, Ftoplevel_exit_handler_function,
// Fputhash(the_stack->handlers, Qeof_error, * err_var)); */
// // ignore /* LispVal *nil_nil = Fpair(Qnil, Qnil); */
// Fpair(Qnil, Qnil)); /* puthash(the_stack->handlers, Qeof_error, */
// while (pos < file_len) { /* // ignore */
// LispVal *tv; /* nil_nil); */
// WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, { /* refcount_unref(nil_nil); */
// pos += read_from_buffer(buffer + pos, file_len - pos, &tv); /* refcount_unref(err_var); */
// }); /* while (pos < file_len) { */
// WITH_CLEANUP(tv, { /* LispVal *tv; */
// IGNORE_REF(Feval(tv)); // /* WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, { */
// }); /* pos += read_from_buffer(buffer + pos, file_len - pos, &tv);
// } */
// }); /* }); */
stack_enter(Qtoplevel, (((LispVal *) (&_Qnil))), 0); /* WITH_CLEANUP(tv, { */
if (_setjmp(the_stack->start) == 0) { /* refcount_unref(Feval(tv)); // */
{ /* }); */
the_stack->hidden = 1; /* } */
LispVal *err_var = /* }); */
(_internal_INTERN_STATIC(("err-var"), sizeof("err-var") - 1)); lisp_shutdown();
Fputhash( return exit_status;
the_stack->handlers, (((LispVal *) (&_Qt))),
const_list(3, err_var,
((LispVal *) (&_Ftoplevel_error_handler_function)),
err_var));
Fputhash(
the_stack->handlers, Qshutdown_signal,
const_list(3, err_var,
((LispVal *) (&_Ftoplevel_exit_handler_function)),
err_var));
Fputhash(the_stack->handlers, Qeof_error,
Fpair((((LispVal *) (&_Qnil))), (((LispVal *) (&_Qnil)))));
while (pos < file_len) {
LispVal *tv;
stack_enter(Qtoplevel_read, (((LispVal *) (&_Qnil))), 0);
if (_setjmp(the_stack->start) == 0) {
{
pos +=
read_from_buffer(buffer + pos, file_len - pos, &tv);
}
}
stack_leave();
;
lisp_ref(tv);
{
void *__with_cleanup_cleanup = register_cleanup(
(lisp_cleanup_func_t) &lisp_unref_double_ptr, &(tv));
{{(lisp_unref(lisp_ref(Feval(tv))));
}
};
cancel_cleanup(__with_cleanup_cleanup);
lisp_unref(tv);
};
}
}
}
stack_leave();
;
lisp_shutdown();
return exit_status;
} }

106
src/read.c
View File

@ -45,9 +45,13 @@ static inline void _internal_read_error(struct ReadState *state, size_t len,
if (len > state->left) { if (len > state->left) {
len = state->left; len = state->left;
} }
LispVal *args = const_list( LispVal *line = make_lisp_integer(state->line);
4, make_lisp_integer(state->line), make_lisp_integer(state->col), LispVal *col = make_lisp_integer(state->col);
make_lisp_string(state->head, len, false, false), desc); LispVal *ctx = make_lisp_string(state->head, len, false, false);
LispVal *args = const_list(4, line, col, ctx, desc);
refcount_unref(line);
refcount_unref(col);
refcount_unref(ctx);
WITH_CLEANUP(args, { WITH_CLEANUP(args, {
Fthrow(cause, args); // Fthrow(cause, args); //
}); });
@ -71,6 +75,14 @@ static bool is_symbol_end(int c) {
static LispVal *read_internal(struct ReadState *state); static LispVal *read_internal(struct ReadState *state);
static bool is_dot_symbol(LispVal *val) {
if (!SYMBOLP(val)) {
return false;
}
LispString *name = ((LispSymbol *) val)->name;
return name->length == 1 && name->data[0] == '.';
}
static LispVal *read_list(struct ReadState *state) { static LispVal *read_list(struct ReadState *state) {
popc(state); // open ( popc(state); // open (
LispVal *list = Qnil; LispVal *list = Qnil;
@ -79,17 +91,36 @@ static LispVal *read_list(struct ReadState *state) {
int c; int c;
while ((c = peekc(state)) != ')') { while ((c = peekc(state)) != ')') {
if (c == EOS) { if (c == EOS) {
UNREF_INPLACE(list); refcount_unref(list);
EOF_ERROR(state); EOF_ERROR(state);
return Qnil;
} }
LispVal *elt = read_internal(state); LispVal *elt = read_internal(state);
if (NILP(list)) { if (is_dot_symbol(elt)) {
if (NILP(list)) {
READ_ERROR(state, 1, "Dot cannot start a list");
}
SKIP_WHITESPACE(state);
if (c == EOS) {
refcount_unref(list);
EOF_ERROR(state);
}
LispVal *last = read_internal(state);
Fsettail(end, last);
refcount_unref(last);
SKIP_WHITESPACE(state);
if (peekc(state) != ')') {
refcount_unref(list);
READ_ERROR(state, 1,
"Dot must be second to last element in list.");
}
break;
} else if (NILP(list)) {
list = Fpair(elt, Qnil); list = Fpair(elt, Qnil);
end = list; end = list;
} else { } else {
LispVal *new_end = Fpair(elt, Qnil); LispVal *new_end = Fpair(elt, Qnil);
Fsettail(end, new_end); Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end; end = new_end;
} }
SKIP_WHITESPACE(state); SKIP_WHITESPACE(state);
@ -108,12 +139,12 @@ static LispVal *read_vector(struct ReadState *state) {
if (c == EOS) { if (c == EOS) {
EOF_ERROR(state); EOF_ERROR(state);
for (size_t i = 0; i < values_len; ++i) { for (size_t i = 0; i < values_len; ++i) {
lisp_unref(values[i]); refcount_unref(values[i]);
} }
lisp_free(values); lisp_free(values);
return Qnil; return Qnil;
} }
LispVal *elt = lisp_ref(read_internal(state)); LispVal *elt = read_internal(state);
values = lisp_realloc(values, sizeof(LispVal *) * ++values_len); values = lisp_realloc(values, sizeof(LispVal *) * ++values_len);
values[values_len - 1] = elt; values[values_len - 1] = elt;
SKIP_WHITESPACE(state); SKIP_WHITESPACE(state);
@ -130,12 +161,12 @@ static LispVal *read_string(struct ReadState *state) {
str[0] = '\0'; str[0] = '\0';
size_t str_len = 0; size_t str_len = 0;
while (backslash || peekc(state) != '"') { while (backslash || peekc(state) != '"') {
c = popc(state);
if (c == EOS) { if (c == EOS) {
lisp_free(str); lisp_free(str);
EOF_ERROR(state); EOF_ERROR(state);
return Qnil; return Qnil;
} }
c = popc(state);
if (!backslash && c == '\\') { if (!backslash && c == '\\') {
backslash = true; backslash = true;
} else if (backslash && c == '\n') { } else if (backslash && c == '\n') {
@ -157,10 +188,10 @@ static LispVal *read_string(struct ReadState *state) {
c = '\0'; c = '\0';
break; break;
case '"': case '"':
c = '"'; case '\\':
// the same character
break; break;
default: default:
// TODO make this point at the correct thing
lisp_free(str); lisp_free(str);
READ_ERROR(state, 1, "unknown escape sequence"); READ_ERROR(state, 1, "unknown escape sequence");
} }
@ -169,7 +200,7 @@ static LispVal *read_string(struct ReadState *state) {
str[str_len - 1] = c; str[str_len - 1] = c;
} }
} }
str[str_len] = '\n'; str[str_len] = '\0';
popc(state); // close " popc(state); // close "
return make_lisp_string(str, str_len, true, false); return make_lisp_string(str, str_len, true, false);
} }
@ -240,12 +271,33 @@ static int parse_base(size_t left, const char *c) {
} }
static LispVal *read_symbol(struct ReadState *state) { static LispVal *read_symbol(struct ReadState *state) {
const char *start = state->head; bool backslash = false;
// TODO allow escaping characters int c;
while (!is_symbol_end(peekc(state))) { char *str = lisp_malloc(1);
popc(state); str[0] = '\0';
size_t str_len = 0;
while (backslash || !is_symbol_end(peekc(state))) {
c = popc(state);
if (!backslash && c == '\\') {
backslash = true;
} else if (!backslash
&& (c == '`' || c == ',' || c == '\'' || c == '"')) {
free(str);
READ_ERROR(state, 1, "invalid character for symbol name");
} else if (c == '\n') {
free(str);
READ_ERROR(state, 1, "backslash not escaping anything");
} else if (c == EOS) {
free(str);
EOF_ERROR(state);
} else {
str = lisp_realloc(str, ++str_len + 1);
str[str_len - 1] = c;
backslash = false;
}
} }
return intern(start, state->head - start, false); str[str_len] = '\0';
return intern(str, str_len, true);
} }
static LispVal *read_number_or_symbol(struct ReadState *state, int base) { static LispVal *read_number_or_symbol(struct ReadState *state, int base) {
@ -350,7 +402,10 @@ static LispVal *read_internal(struct ReadState *state) {
case '\'': { case '\'': {
popc(state); // ' popc(state); // '
LispVal *tail = read_internal(state); LispVal *tail = read_internal(state);
return Fpair(Qquote, Fpair(tail, Qnil)); LispVal *res = Fpair(Qquote, Fpair(tail, Qnil));
refcount_unref(tail);
refcount_unref(TAIL(res));
return res;
} }
// backquote // backquote
case '`': { case '`': {
@ -358,16 +413,27 @@ static LispVal *read_internal(struct ReadState *state) {
++state->backquote_level; ++state->backquote_level;
LispVal *tail = read_internal(state); LispVal *tail = read_internal(state);
--state->backquote_level; --state->backquote_level;
return Fpair(Qbackquote, Fpair(tail, Qnil)); LispVal *res = Fpair(Qbackquote, Fpair(tail, Qnil));
refcount_unref(tail);
refcount_unref(TAIL(res));
return res;
} }
// comma // comma
case ',': case ',':
popc(state); // , popc(state); // ,
if (state->backquote_level) { if (state->backquote_level) {
LispVal *func = Qcomma;
if (peekc(state) == '@') {
popc(state);
func = Qcomma_at;
}
--state->backquote_level; --state->backquote_level;
LispVal *tail = read_internal(state); LispVal *tail = read_internal(state);
++state->backquote_level; ++state->backquote_level;
return Fpair(Qcomma, Fpair(tail, Qnil)); LispVal *res = Fpair(func, Fpair(tail, Qnil));
refcount_unref(tail);
refcount_unref(TAIL(res));
return res;
} else { } else {
READ_ERROR(state, 1, "comma not inside backquote"); READ_ERROR(state, 1, "comma not inside backquote");
return Qnil; return Qnil;

5
src/read.h
View File

@ -5,11 +5,6 @@
#include <stddef.h> #include <stddef.h>
typedef enum {
SEVERITY_WARN,
SEVERITY_ERROR,
} ReadErrorSeverity;
size_t read_from_buffer(const char *text, size_t length, LispVal **out); size_t read_from_buffer(const char *text, size_t length, LispVal **out);
DECLARE_FUNCTION(read, (LispVal * source)); DECLARE_FUNCTION(read, (LispVal * source));