From dec35ab80b9cc3b83b3a806835198b0a58cdc0cb Mon Sep 17 00:00:00 2001 From: Mistivia Date: Wed, 23 Jul 2025 17:29:42 +0800 Subject: add ext --- .gitignore | 1 + Makefile | 21 ++++++--- ext_example/vector.c | 128 +++++++++++++++++++++++++++++++++++++++++++++++++++ interp.c | 6 +-- primitives.c | 30 ++++++++++++ primitives.h | 1 + tests/vector.lisp | 2 + vector.c | 128 --------------------------------------------------- vector.h | 8 ---- 9 files changed, 178 insertions(+), 147 deletions(-) create mode 100644 ext_example/vector.c delete mode 100644 vector.c delete mode 100644 vector.h diff --git a/.gitignore b/.gitignore index ba23bfc..351af1b 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ *.d *.a *.bin +*.so bamboo-lisp compile_commands.json .cache diff --git a/Makefile b/Makefile index 77a9aae..a1a4a4c 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ mode ?= debug cc = gcc -includes = -DWITHREADLINE +includes = -DWITHREADLINE -fPIC ldflags = -lm -lreadline -lalgds ifeq ($(mode), debug) @@ -9,7 +9,7 @@ ifeq ($(mode), debug) -g \ -fsanitize=address else - cflags = $(includes) -g -O2 + cflags = $(includes) -O2 endif src = $(shell find ./ -maxdepth 1 -name '*.c' -not -name 'main.c') @@ -20,8 +20,11 @@ tests_bin=$(tests:.c=.bin) all: bamboo-lisp -install: bamboo-lisp - sudo cp bamboo-lisp /usr/local/bin/bamboo +install: bamboo-lisp libbamboo-lisp.a + sudo cp bamboo-lisp /usr/local/bin/bamboo-lisp + sudo cp libbamboo-lisp.a /usr/local/lib/ + sudo mkdir -p /usr/local/include/bamboo_lisp + sudo cp *.h /usr/local/include/bamboo_lisp/ prelude.c: prelude.lisp cat prelude.lisp | python scripts/genprelude.py > prelude.c @@ -32,7 +35,10 @@ bamboo-lisp: $(obj) main.o libbamboo-lisp.a: $(obj) ar cr $@ $^ -test: bamboo-lisp $(tests_bin) +ext_example/vector.so: ext_example/vector.c libbamboo-lisp.a + gcc -shared $(cflags) -I./ -o $@ $^ $(ldflags) + +test: bamboo-lisp $(tests_bin) ext_example/vector.so @echo @echo "Run tests:" @scripts/runall.sh $(tests_bin) @@ -52,7 +58,10 @@ $(tests_bin):%.bin:%.c $(obj) $(libs) clean: -rm $(shell find tests/ -name '*.bin') - -rm $(shell find . -name '*.o' -or -name '*.a' -or -name '*.d') + -rm $(shell find . -name '*.so') + -rm $(shell find . -name '*.o') + -rm $(shell find . -name '*.a') + -rm $(shell find . -name '*.d') -rm bamboo-lisp DEPS := $(shell find . -name '*.d') diff --git a/ext_example/vector.c b/ext_example/vector.c new file mode 100644 index 0000000..0aa3006 --- /dev/null +++ b/ext_example/vector.c @@ -0,0 +1,128 @@ +#include "interp.h" +#include "sexp.h" + +LispUserdataMeta bamboo_lisp_array_meta; + +static bool is_vector_impl(Interp *interp, SExpRef vec) { + if (VALTYPE(vec) == kUserDataSExp && strcmp("vector", REF(vec)->userdata_meta->type) == 0) { + return true; + } + return false; +} + +static SExpRef is_vector(Interp* interp, SExpRef args) { + if (LENGTH(args) != 1) return new_error(interp, "vector?: wrongs args num.\n"); + return new_boolean(interp, is_vector_impl(interp, CAR(args))); +} + +static SExpRef make_vector(Interp* interp, SExpRef args) { + SExpRef ret = new_sexp(interp); + REF(ret)->type = kUserDataSExp; + REF(ret)->userdata_meta = &bamboo_lisp_array_meta; + SExpRefVector *data = malloc(sizeof(SExpRefVector)); + SExpRefVector_init(data); + REF(ret)->userdata = data; + return ret; +} + +static SExpRef vector_ref(Interp* interp, SExpRef args) { + if (LENGTH(args) != 2) return new_error(interp, "vector-ref: wrong args num.\n"); + if (!is_vector_impl(interp, CAR(args)) + || REF(CADR(args))->type != kIntegerSExp) { + return new_error(interp, "vector-ref: wrong type.\n"); + } + int n = REF(CADR(args))->integer; + SExpRefVector *vec = REF(CAR(args))->userdata; + if (n >= SExpRefVector_len(vec)) return new_error(interp, "vector-ref: out of bound.\n"); + SExpRef ret = new_sexp(interp); + return *SExpRefVector_ref(vec, n); +} + +static SExpRef vector_append(Interp* interp, SExpRef args) { + if (LENGTH(args) != 2) return new_error(interp, "vector-append: wrong args num.\n"); + if (!is_vector_impl(interp, CAR(args))) return new_error(interp, "vector-append: first arg not a vector.\n"); + + SExpRefVector *vec = REF(CAR(args))->userdata; + SExpRef elem = CADR(args); + SExpRefVector_push_back(vec, elem); + return NIL; +} + +static SExpRef vector_insert(Interp* interp, SExpRef args) { + if (LENGTH(args) != 3) return new_error(interp, "vector-insert: wrong args num.\n"); + if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp) + return new_error(interp, "vector-insert: wrong types.\n"); + + int pos = REF(CADR(args))->integer; + SExpRefVector *vec = REF(CAR(args))->userdata; + SExpRef elem = CADDR(args); + SExpRefVector_insert_before(vec, pos, elem); + return NIL; +} + +static SExpRef vector_delete(Interp* interp, SExpRef args) { + if (LENGTH(args) != 2) return new_error(interp, "vector-remove: wrong args num.\n"); + if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp) + return new_error(interp, "vector-remove: wrong types.\n"); + + int pos = REF(CADR(args))->integer; + SExpRefVector *vec = REF(CAR(args))->userdata; + if (pos >= SExpRefVector_len(vec)) return new_error(interp, "vector-remove: out of bound.\n"); + SExpRefVector_remove(vec, pos); + return NIL; +} + +static SExpRef vector_length(Interp* interp, SExpRef args) { + if (LENGTH(args) != 1) return new_error(interp, "vector-length: wrong args num.\n"); + if (!is_vector_impl(interp, CAR(args))) return new_error(interp, "vector-length: not a vector.\n"); + + SExpRefVector *vec = REF(CAR(args))->userdata; + return new_integer(interp, SExpRefVector_len(vec)); +} + +static SExpRef vector_set(Interp* interp, SExpRef args) { + if (LENGTH(args) != 3) return new_error(interp, "vector-set: wrong args num.\n"); + if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp) + return new_error(interp, "vector-set: wrong types.\n"); + + int pos = REF(CADR(args))->integer; + SExpRefVector *vec = REF(CAR(args))->userdata; + if (pos >= SExpRefVector_len(vec)) return new_error(interp, "vector-set: out of bound.\n"); + + *SExpRefVector_ref(vec, pos) = CADDR(args); + return NIL; +} + +static void vector_free(void *vself) { + SExpRefVector *self = vself; + SExpRefVector_free(self); + free(self); +} + +static void vector_gcmark(Interp *interp, SExpPtrVector *gcstack, void *vself) { + SExpRefVector *vec = (SExpRefVector *)vself; + int vecsize = SExpRefVector_len(vec); + for (int i = 0; i < vecsize; ++i) { + SExpPtr child = REF(*SExpRefVector_ref(vec, i)); + if (child && !child->marked) { + SExpPtrVector_push_back(gcstack, child); + } + } +} + + +int bamboo_lisp_ext_init(Interp *interp) { + bamboo_lisp_array_meta.type = "vector"; + bamboo_lisp_array_meta.free = &vector_free; + bamboo_lisp_array_meta.gcmark = &vector_gcmark; + + Interp_add_userfunc(interp, "vector?", &is_vector); + Interp_add_userfunc(interp, "make-vector", &make_vector); + Interp_add_userfunc(interp, "vector-ref", &vector_ref); + Interp_add_userfunc(interp, "vector-append", &vector_append); + Interp_add_userfunc(interp, "vector-insert", &vector_insert); + Interp_add_userfunc(interp, "vector-remove", &vector_delete); + Interp_add_userfunc(interp, "vector-length", &vector_length); + Interp_add_userfunc(interp, "vector-set", &vector_set); + return 1; +} diff --git a/interp.c b/interp.c index dbc790f..4adcda2 100644 --- a/interp.c +++ b/interp.c @@ -12,8 +12,6 @@ #include "parser.h" #include "prelude.h" -#include "vector.h" - #define BUFSIZE 1024 bool SExpRef_eq(SExpRef a, SExpRef b) { @@ -148,6 +146,7 @@ void Interp_init(Interp *self) { Interp_add_primitive(self, "assert-error", primitive_assert_error); Interp_add_primitive(self, "assert-exception", primitive_assert_exception); Interp_add_primitive(self, "load", primitive_load); + Interp_add_primitive(self, "loadext", primitive_loadext); Interp_add_primitive(self, "try", primitive_try); Interp_add_primitive(self, "unwind-protect", primitive_unwind_protect); @@ -260,9 +259,6 @@ void Interp_init(Interp *self) { Interp_add_userfunc(self, "_gcstat", builtin_gcstat); Interp_add_userfunc(self, "_alwaysgc", builtin_alwaysgc); - // extentions - bamboo_lisp_init_vector(self); - SExpRef ret = Interp_eval_string(self, bamboo_lisp_prelude); Interp *interp = self; if (VALTYPE(ret) == kErrSignal) { diff --git a/primitives.c b/primitives.c index 971aa87..1b49bfe 100644 --- a/primitives.c +++ b/primitives.c @@ -3,6 +3,8 @@ #include "sexp.h" #include "parser.h" +#include + SExpRef primitive_assert_exception(Interp *interp, SExpRef args, bool istail) { SExpRef eargs = lisp_eval_args(interp, args); if (VALTYPE(eargs) == kExceptionSignal) return interp->t; @@ -69,6 +71,34 @@ SExpRef primitive_load(Interp *interp, SExpRef args, bool istail) { return ret; } +typedef int (*BambooLispExtInitFn)(Interp *interp); + +SExpRef primitive_loadext(Interp *interp, SExpRef args, bool istail) { + if (CAR(interp->stack).idx != interp->top_level.idx) { + return new_error(interp, "loadext: loadext can only be in top level.\n"); + } + if (LENGTH(args) != 1) return new_error(interp, "loadext: syntax error.\n"); + args = lisp_eval_args(interp, args); + if (VALTYPE(CAR(args)) != kStringSExp) return new_error(interp, "loadext: syntax error.\n"); + const char *filename = REF(CAR(args))->str; + void *handle = dlopen(filename, RTLD_LAZY); + if (!handle) { + return new_error(interp, "Failed to load library: %s\n", dlerror()); + } + dlerror(); + BambooLispExtInitFn init_func = (BambooLispExtInitFn)dlsym(handle, "bamboo_lisp_ext_init"); + const char *error; + if ((error = dlerror()) != NULL) { + dlclose(handle); + return new_error(interp, "Failed to locate symbol: %s\n", error); + } + int ret = (*init_func)(interp); + if (ret < 0) { + return new_error(interp, "Failed to init ext: %s\n", filename); + } + return NIL; +} + SExpRef primitive_return(Interp *interp, SExpRef args, bool istail) { if (LENGTH(args) > 1) { return new_error(interp, "return: syntax error.\n"); diff --git a/primitives.h b/primitives.h index cd686fe..ae97b64 100644 --- a/primitives.h +++ b/primitives.h @@ -6,6 +6,7 @@ SExpRef primitive_assert_error(Interp *interp, SExpRef sexp, bool istail); SExpRef primitive_assert_exception(Interp *interp, SExpRef sexp, bool istail); SExpRef primitive_load(Interp *interp, SExpRef sexp, bool istail); +SExpRef primitive_loadext(Interp *interp, SExpRef sexp, bool istail); SExpRef primitive_return(Interp *interp, SExpRef sexp, bool istail); SExpRef primitive_break(Interp *interp, SExpRef sexp, bool istail); SExpRef primitive_continue(Interp *interp, SExpRef sexp, bool istail); diff --git a/tests/vector.lisp b/tests/vector.lisp index d4f7231..10afde4 100644 --- a/tests/vector.lisp +++ b/tests/vector.lisp @@ -1,3 +1,5 @@ +(loadext "ext_example/vector.so") + (assert (vector? (make-vector))) (assert (not (vector? 1))) diff --git a/vector.c b/vector.c deleted file mode 100644 index 453800b..0000000 --- a/vector.c +++ /dev/null @@ -1,128 +0,0 @@ -#include "vector.h" -#include "interp.h" -#include "sexp.h" - -LispUserdataMeta bamboo_lisp_array_meta; - -static bool is_vector_impl(Interp *interp, SExpRef vec) { - if (VALTYPE(vec) == kUserDataSExp && strcmp("vector", REF(vec)->userdata_meta->type) == 0) { - return true; - } - return false; -} - -static SExpRef is_vector(Interp* interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "vector?: wrongs args num.\n"); - return new_boolean(interp, is_vector_impl(interp, CAR(args))); -} - -static SExpRef make_vector(Interp* interp, SExpRef args) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kUserDataSExp; - REF(ret)->userdata_meta = &bamboo_lisp_array_meta; - SExpRefVector *data = malloc(sizeof(SExpRefVector)); - SExpRefVector_init(data); - REF(ret)->userdata = data; - return ret; -} - -static SExpRef vector_ref(Interp* interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "vector-ref: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args)) - || REF(CADR(args))->type != kIntegerSExp) { - return new_error(interp, "vector-ref: wrong type.\n"); - } - int n = REF(CADR(args))->integer; - SExpRefVector *vec = REF(CAR(args))->userdata; - if (n >= SExpRefVector_len(vec)) return new_error(interp, "vector-ref: out of bound.\n"); - SExpRef ret = new_sexp(interp); - return *SExpRefVector_ref(vec, n); -} - -static SExpRef vector_append(Interp* interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "vector-append: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args))) return new_error(interp, "vector-append: first arg not a vector.\n"); - - SExpRefVector *vec = REF(CAR(args))->userdata; - SExpRef elem = CADR(args); - SExpRefVector_push_back(vec, elem); - return NIL; -} - -static SExpRef vector_insert(Interp* interp, SExpRef args) { - if (LENGTH(args) != 3) return new_error(interp, "vector-insert: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp) - return new_error(interp, "vector-insert: wrong types.\n"); - - int pos = REF(CADR(args))->integer; - SExpRefVector *vec = REF(CAR(args))->userdata; - SExpRef elem = CADDR(args); - SExpRefVector_insert_before(vec, pos, elem); - return NIL; -} - -static SExpRef vector_delete(Interp* interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "vector-remove: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp) - return new_error(interp, "vector-remove: wrong types.\n"); - - int pos = REF(CADR(args))->integer; - SExpRefVector *vec = REF(CAR(args))->userdata; - if (pos >= SExpRefVector_len(vec)) return new_error(interp, "vector-remove: out of bound.\n"); - SExpRefVector_remove(vec, pos); - return NIL; -} - -static SExpRef vector_length(Interp* interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "vector-length: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args))) return new_error(interp, "vector-length: not a vector.\n"); - - SExpRefVector *vec = REF(CAR(args))->userdata; - return new_integer(interp, SExpRefVector_len(vec)); -} - -static SExpRef vector_set(Interp* interp, SExpRef args) { - if (LENGTH(args) != 3) return new_error(interp, "vector-set: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp) - return new_error(interp, "vector-set: wrong types.\n"); - - int pos = REF(CADR(args))->integer; - SExpRefVector *vec = REF(CAR(args))->userdata; - if (pos >= SExpRefVector_len(vec)) return new_error(interp, "vector-set: out of bound.\n"); - - *SExpRefVector_ref(vec, pos) = CADDR(args); - return NIL; -} - -static void vector_free(void *vself) { - SExpRefVector *self = vself; - SExpRefVector_free(self); - free(self); -} - -static void vector_gcmark(Interp *interp, SExpPtrVector *gcstack, void *vself) { - SExpRefVector *vec = (SExpRefVector *)vself; - int vecsize = SExpRefVector_len(vec); - for (int i = 0; i < vecsize; ++i) { - SExpPtr child = REF(*SExpRefVector_ref(vec, i)); - if (child && !child->marked) { - SExpPtrVector_push_back(gcstack, child); - } - } -} - - -void bamboo_lisp_init_vector(Interp *interp) { - bamboo_lisp_array_meta.type = "vector"; - bamboo_lisp_array_meta.free = &vector_free; - bamboo_lisp_array_meta.gcmark = &vector_gcmark; - - Interp_add_userfunc(interp, "vector?", &is_vector); - Interp_add_userfunc(interp, "make-vector", &make_vector); - Interp_add_userfunc(interp, "vector-ref", &vector_ref); - Interp_add_userfunc(interp, "vector-append", &vector_append); - Interp_add_userfunc(interp, "vector-insert", &vector_insert); - Interp_add_userfunc(interp, "vector-remove", &vector_delete); - Interp_add_userfunc(interp, "vector-length", &vector_length); - Interp_add_userfunc(interp, "vector-set", &vector_set); -} diff --git a/vector.h b/vector.h deleted file mode 100644 index 34113d1..0000000 --- a/vector.h +++ /dev/null @@ -1,8 +0,0 @@ -#ifndef BAMBOO_LISP_VECTOR_H_ -#define BAMBOO_LISP_VECTOR_H_ - -#include "interp.h" - -void bamboo_lisp_init_vector(Interp *interp); - -#endif -- cgit v1.0