From de7b14ffe2bcef8f9a6a254f1a692c89819c81d8 Mon Sep 17 00:00:00 2001 From: Benjamin Vedder Date: Sun, 3 Apr 2022 12:26:23 +0200 Subject: [PATCH] Squashed 'lispBM/lispBM/' changes from 6deae379..ccca9778 ccca9778 update lbmred.md e182bffd changed doc i28 to i 3b277e28 error message printing verbosity level can be toggled between high and low 0f00e692 update one of the call-cc tests 6a377f74 added some tests of call-cc 4f3e8adc update application of a call-cc continuation. zero arguments is ok, will apply to nil. More than 1 argument is an error and terminates the context 50fdd498 small tweaks to repl-cps git-subtree-dir: lispBM/lispBM git-subtree-split: ccca9778ee0ddad6ea44bdc309ba128c92723309 --- doc/lbmref.md | 29 ++++++++++++++--- include/eval_cps.h | 8 +++++ include/lbm_version.h | 6 +++- repl-cps/repl.c | 29 +++-------------- src/eval_cps.c | 68 +++++++++++++++++++++++++++------------- tests/test_callcc_1.lisp | 6 ++++ tests/test_callcc_2.lisp | 3 ++ tests/test_callcc_3.lisp | 9 ++++++ 8 files changed, 106 insertions(+), 52 deletions(-) create mode 100644 tests/test_callcc_1.lisp create mode 100644 tests/test_callcc_2.lisp create mode 100644 tests/test_callcc_3.lisp diff --git a/doc/lbmref.md b/doc/lbmref.md index 6d9ee724..633ab38e 100644 --- a/doc/lbmref.md +++ b/doc/lbmref.md @@ -13,7 +13,7 @@ Example adding up two numbers. The result is 3. ``` When adding up values of different types values are converted. ```clj -(+ 1i28 3.14) +(+ 1i 3.14) ``` The example above evaluates to float value 4.14.
You can add up multiple values. @@ -1053,9 +1053,9 @@ will block on a `recv` until there is a matching message in the mailbox. The `recv` syntax is very similar to [match](./lbmref.md#match). -Example where a process waits for an i28 +Example where a process waits for an integer `?i`. ```clj -(recv ( (?i28 n) (+ n 1) )) +(recv ( (?i n) (+ n 1) )) ``` @@ -1223,11 +1223,18 @@ variable (symbol) that is neighter bound nor special (built-in function). --- -### type-i28 +### type-i + +A value with type `type-i` occupy 28bits on the 32 bit version of LBM and +56bits on the 64bit version. --- -### type-u28 +### type-u + +A value with type `type-u` occupy 28bits on the 32 bit version of LBM and +56bits on the 64bit version. + --- @@ -1243,6 +1250,18 @@ variable (symbol) that is neighter bound nor special (built-in function). --- +### type-i64 + +--- + +### type-u64 + +--- + +### type-double + +--- + ### type-array --- diff --git a/include/eval_cps.h b/include/eval_cps.h index d49b4aa2..b92fb923 100644 --- a/include/eval_cps.h +++ b/include/eval_cps.h @@ -183,6 +183,14 @@ extern void lbm_blocked_iterator(ctx_fun f, void*, void*); * \param arg2 Same as above */ extern void lbm_done_iterator(ctx_fun f, void*, void*); +/** toggle verbosity level of error messages + */ +extern void lbm_toggle_verbose(void); +/** Set verbosity level of lispbm error messages. + * + * \param verbose Boolean to turn verbose errors on or off. + */ +extern void lbm_set_verbose(bool verbose); /** Set a usleep callback for use by the evaluator thread. * * \param fptr Pointer to a sleep function. diff --git a/include/lbm_version.h b/include/lbm_version.h index 1463e964..f1003438 100644 --- a/include/lbm_version.h +++ b/include/lbm_version.h @@ -25,10 +25,14 @@ /** LBM minor version */ #define LBM_MINOR_VERSION 5 /** LBM patch revision */ -#define LBM_PATCH_VERSION 0 +#define LBM_PATCH_VERSION 1 /*! \page changelog Changelog +Apr 02 2022: Version 0.5.1 + - A continuation created by call-cc can be applied to 0 or 1 argument. + If there are 0 arguments an implicit application to nil takes place. + Mar 26 2022: Version (0.5.0) - Optimized code-path for closure applications. - 64 and 32 bit support from a single source code diff --git a/repl-cps/repl.c b/repl-cps/repl.c index 4fc80904..9c856fde 100644 --- a/repl-cps/repl.c +++ b/repl-cps/repl.c @@ -97,6 +97,8 @@ int inputline(char *buffer, unsigned int size) { continue; } switch (c) { + case 27: + break; case 127: /* fall through to below */ case '\b': /* backspace character received */ if (n > 0) @@ -252,23 +254,6 @@ static lbm_value ext_range(lbm_value *args, lbm_uint argn) { } -static lbm_value ext_get_bms_val(lbm_value *args, lbm_uint argn) { - lbm_value res = lbm_enc_sym(SYM_EERROR); - - if (argn != 1 && argn != 2) { - return lbm_enc_sym(SYM_EERROR); - } - - char *name = lbm_dec_str(args[0]); - - if (!name) { - return lbm_enc_sym(SYM_EERROR); - } - - res = lbm_enc_i(20); - return res; -} - /* load a file, caller is responsible for freeing the returned string */ char * load_file(char *filename) { @@ -416,13 +401,6 @@ int main(int argc, char **argv) { else printf("Error adding extension.\n"); - - res = lbm_add_extension("get-bms-val", ext_get_bms_val); - if (res) - printf("Extension added.\n"); - else - printf("Error adding extension.\n"); - res = lbm_add_extension("range", ext_range); if (res) printf("Extension added.\n"); @@ -502,6 +480,9 @@ int main(int argc, char **argv) { printf("started ctx: %"PRI_UINT"\n", cid); } + } else if (n >= 5 && strncmp(str, ":verb", 5) == 0) { + lbm_toggle_verbose(); + continue; } else if (n >= 4 && strncmp(str, ":pon", 4) == 0) { allow_print = true; continue; diff --git a/src/eval_cps.c b/src/eval_cps.c index 1a56950a..5b9340de 100644 --- a/src/eval_cps.c +++ b/src/eval_cps.c @@ -221,6 +221,16 @@ static void (*ctx_done_callback)(eval_context_t *) = NULL; static int (*printf_callback)(const char *, ...) = NULL; static bool (*dynamic_load_callback)(const char *, const char **) = NULL; +static bool lbm_verbose = false; + +void lbm_toggle_verbose(void) { + lbm_verbose = !lbm_verbose; +} + +void lbm_set_verbose(bool verbose) { + lbm_verbose = verbose; +} + void lbm_set_usleep_callback(void (*fptr)(uint32_t)) { usleep_callback = fptr; } @@ -350,27 +360,27 @@ void print_error_message(lbm_value error) { printf_callback("***\tError: %s\n\n", buf); if (ctx_running->error_reason) { - printf_callback("Reason:\n%s\n\n", ctx_running->error_reason); + printf_callback("Reason:\n\t%s\n\n", ctx_running->error_reason); } + if (lbm_verbose) { + lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->curr_exp); + printf_callback("\tWhile evaluating: %s\n", buf); + printf_callback("\tIn context: %d\n", ctx_running->id); + printf_callback("\tCurrent intermediate result: %s\n\n", buf); - lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->curr_exp); - printf_callback("\tWhile evaluating: %s\n", buf); - printf_callback("\tIn context: %d\n", ctx_running->id); - printf_callback("\tCurrent intermediate result: %s\n\n", buf); + print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES); + printf_callback("\n\n"); - print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES); - printf_callback("\n\n"); + printf_callback("\tError explanation:\n"); + print_error_explanation(error, buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES); + printf_callback("\n\n"); - printf_callback("\tError explanation:\n"); - print_error_explanation(error, buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES); - printf_callback("\n\n"); - - printf_callback("\tStack:\n"); - for (unsigned int i = 0; i < ctx_running->K.sp; i ++) { - lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->K.data[i]); - printf_callback("\t\t%s\n", buf); + printf_callback("\tStack:\n"); + for (unsigned int i = 0; i < ctx_running->K.sp; i ++) { + lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->K.data[i]); + printf_callback("\t\t%s\n", buf); + } } - lbm_memory_free(buf32); } @@ -1323,11 +1333,15 @@ static inline void eval_lambda(eval_context_t *ctx) { static inline void eval_if(eval_context_t *ctx) { + lbm_value cddr = lbm_cdr(lbm_cdr(ctx->curr_exp)); + lbm_value then_branch = lbm_car(cddr); + lbm_value else_branch = lbm_car(lbm_cdr(cddr)); + CHECK_STACK(lbm_push_4(&ctx->K, - lbm_car(lbm_cdr(lbm_cdr(lbm_cdr(ctx->curr_exp)))), // Else branch - lbm_car(lbm_cdr(lbm_cdr(ctx->curr_exp))), // Then branch - ctx->curr_env, - lbm_enc_u(IF))); + else_branch, + then_branch, + ctx->curr_env, + lbm_enc_u(IF))); ctx->curr_exp = lbm_car(lbm_cdr(ctx->curr_exp)); } @@ -1579,7 +1593,9 @@ static inline void cont_application(eval_context_t *ctx) { lbm_value count; lbm_pop(&ctx->K, &count); - lbm_uint *fun_args = lbm_get_stack_ptr(&ctx->K, lbm_dec_u(count)+1); + lbm_uint arg_count = lbm_dec_u(count); + + lbm_uint *fun_args = lbm_get_stack_ptr(&ctx->K, arg_count+1); if (fun_args == NULL) { ctx->r = lbm_enc_sym(SYM_FATAL_ERROR); @@ -1594,7 +1610,15 @@ static inline void cont_application(eval_context_t *ctx) { error_ctx(lbm_enc_sym(SYM_FATAL_ERROR)); return; } - lbm_value arg = fun_args[1]; + + lbm_value arg = NIL; + if (arg_count == 1) { + arg = fun_args[1]; + } else if (arg_count > 1) { + lbm_set_error_reason("A continuation created by call-cc was applied to too many arguments (>1)"); + error_ctx(lbm_enc_sym(SYM_EERROR)); + return; + } lbm_stack_clear(&ctx->K); lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(c); diff --git a/tests/test_callcc_1.lisp b/tests/test_callcc_1.lisp new file mode 100644 index 00000000..6b57db4c --- /dev/null +++ b/tests/test_callcc_1.lisp @@ -0,0 +1,6 @@ + +(define f (lambda (x) (+ x 1))) + + + +(= (f (call-cc (lambda (k) (k 10)))) 11) diff --git a/tests/test_callcc_2.lisp b/tests/test_callcc_2.lisp new file mode 100644 index 00000000..d3570bc2 --- /dev/null +++ b/tests/test_callcc_2.lisp @@ -0,0 +1,3 @@ + + +(eq (call-cc (lambda (k) (k))) 'nil) diff --git a/tests/test_callcc_3.lisp b/tests/test_callcc_3.lisp new file mode 100644 index 00000000..9f9c1910 --- /dev/null +++ b/tests/test_callcc_3.lisp @@ -0,0 +1,9 @@ + +(define f (lambda (x) + (if (= x 0) + x + ( = 10 + (call-cc (lambda (k) (progn (define cc k) (f (- x 1))))))))) + +(f 1) +(cc 10)