From 19a0a7cc3f7a8514be8ba5fb07a371c9c8d22ef2 Mon Sep 17 00:00:00 2001 From: Benjamin Vedder Date: Sun, 31 Mar 2024 19:00:36 +0200 Subject: [PATCH] Squashed 'lispBM/lispBM/' changes from 1dd732d9..418272ad 418272ad added a way to load flattened environments into the heap on startup as a library. And added a library for cleaning of closure environments for future experimentation 74eefd1e bugfix in progn variables related to recursive binginds 93536f76 added a member function for list membership checks git-subtree-dir: lispBM/lispBM git-subtree-split: 418272ad1454ee414739fe0aef1b30aa9b56002c --- doc/lbmref.lisp | 12 +++++ doc/lbmref.md | 52 ++++++++++++++++++++ include/lbm_defines.h | 2 + repl/clean_cl.h | 95 ++++++++++++++++++++++++++++++++++++ repl/repl.c | 82 ++++++++++++++++++++++++++++++- repl/repl_exts.c | 35 ++++++++++++- src/eval_cps.c | 16 ++++++ src/fundamental.c | 19 ++++++++ src/symrepr.c | 1 + tests/test_member_1.lisp | 6 +++ tests/test_member_2.lisp | 2 + tests/test_member_3.lisp | 1 + tests/test_progn_var_10.lisp | 8 +++ tests/test_progn_var_11.lisp | 9 ++++ 14 files changed, 338 insertions(+), 2 deletions(-) create mode 100644 repl/clean_cl.h create mode 100644 tests/test_member_1.lisp create mode 100644 tests/test_member_2.lisp create mode 100644 tests/test_member_3.lisp create mode 100644 tests/test_progn_var_10.lisp create mode 100644 tests/test_progn_var_11.lisp diff --git a/doc/lbmref.lisp b/doc/lbmref.lisp index 53b4650d..793128fc 100644 --- a/doc/lbmref.lisp +++ b/doc/lbmref.lisp @@ -1819,6 +1819,17 @@ )) end))) +(define lists-member + (ref-entry "member" + (list + (para (list "`member` checks if a list contains a given element." + "The form of a `member` expression is `(member list-exp exp)`." + )) + (code '((member (list 1 2 3) 5) + (member (list 1 2 3) 2) + )) + end))) + (define lists-rotate (ref-entry "rotate" @@ -1907,6 +1918,7 @@ lists-setcdr lists-take lists-drop + lists-member lists-reverse lists-rotate lists-merge diff --git a/doc/lbmref.md b/doc/lbmref.md index bd41dc7f..7b6de123 100644 --- a/doc/lbmref.md +++ b/doc/lbmref.md @@ -4941,6 +4941,58 @@ apa +--- + + +### member + +`member` checks if a list contains a given element. The form of a `member` expression is `(member list-exp exp)`. + + + + + + + + + + + + + +
Example Result
+ +```clj +(member (list 1 2 3) 5) +``` + + + + +```clj +nil +``` + + +
+ +```clj +(member (list 1 2 3) 2) +``` + + + + +```clj +(1 2 3) +``` + + +
+ + + + --- diff --git a/include/lbm_defines.h b/include/lbm_defines.h index 84c92b5e..b805919d 100644 --- a/include/lbm_defines.h +++ b/include/lbm_defines.h @@ -312,6 +312,7 @@ #define SYM_REG_EVENT_HANDLER 0x20037 #define SYM_TAKE 0x20038 #define SYM_DROP 0x20039 +#define SYM_MEMBER 0x2003A // Apply funs: // Get their arguments in evaluated form on the stack. @@ -535,5 +536,6 @@ #define ENC_SYM_REG_EVENT_HANDLER ENC_SYM(SYM_REG_EVENT_HANDLER) #define ENC_SYM_TAKE ENC_SYM(SYM_TAKE) #define ENC_SYM_DROP ENC_SYM(SYM_DROP) +#define ENC_SYM_MEMBER ENC_SYM(SYM_MEMBER) #endif diff --git a/repl/clean_cl.h b/repl/clean_cl.h new file mode 100644 index 00000000..85241a73 --- /dev/null +++ b/repl/clean_cl.h @@ -0,0 +1,95 @@ +unsigned char clean_cl_env[] = { + 0x0a, 0x00, 0x00, 0x00, 0x73, 0x65, 0x74, 0x2d, 0x69, 0x6e, 0x73, 0x65, + 0x72, 0x74, 0xdc, 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x73, + 0x75, 0x72, 0x65, 0x00, 0x01, 0x01, 0x03, 0x61, 0x00, 0x01, 0x03, 0x73, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, 0x61, 0x74, + 0x63, 0x68, 0x00, 0x01, 0x03, 0x73, 0x00, 0x01, 0x01, 0x03, 0x6e, 0x69, + 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6c, 0x69, 0x73, 0x74, 0x00, 0x01, 0x03, + 0x61, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x01, 0x01, 0x01, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x00, 0x03, + 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x73, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x65, 0x71, 0x00, + 0x01, 0x03, 0x65, 0x00, 0x01, 0x03, 0x61, 0x00, 0x03, 0x6e, 0x69, 0x6c, + 0x00, 0x01, 0x03, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, + 0x01, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x00, 0x03, 0x6e, 0x69, + 0x6c, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x73, 0x00, 0x03, + 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x63, 0x6f, 0x6e, 0x73, 0x00, + 0x01, 0x03, 0x65, 0x00, 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, 0x2d, 0x69, + 0x6e, 0x73, 0x65, 0x72, 0x74, 0x00, 0x01, 0x03, 0x61, 0x00, 0x01, 0x03, + 0x65, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x09, 0x00, + 0x00, 0x00, 0x73, 0x65, 0x74, 0x2d, 0x75, 0x6e, 0x69, 0x6f, 0x6e, 0x9f, + 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x73, 0x75, 0x72, 0x65, + 0x00, 0x01, 0x01, 0x03, 0x73, 0x31, 0x00, 0x01, 0x03, 0x73, 0x32, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, 0x61, 0x74, 0x63, + 0x68, 0x00, 0x01, 0x03, 0x73, 0x31, 0x00, 0x01, 0x01, 0x03, 0x6e, 0x69, + 0x6c, 0x00, 0x01, 0x03, 0x73, 0x32, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x01, 0x01, 0x01, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x00, 0x03, + 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x73, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, + 0x2d, 0x75, 0x6e, 0x69, 0x6f, 0x6e, 0x00, 0x01, 0x03, 0x65, 0x73, 0x00, + 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, 0x2d, 0x69, 0x6e, 0x73, 0x65, 0x72, + 0x74, 0x00, 0x01, 0x03, 0x65, 0x00, 0x01, 0x03, 0x73, 0x32, 0x00, 0x03, + 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, + 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x08, 0x00, 0x00, 0x00, 0x67, 0x65, + 0x74, 0x2d, 0x76, 0x61, 0x72, 0x73, 0xf7, 0x00, 0x00, 0x00, 0x01, 0x03, + 0x63, 0x6c, 0x6f, 0x73, 0x75, 0x72, 0x65, 0x00, 0x01, 0x01, 0x03, 0x62, + 0x6f, 0x64, 0x79, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, + 0x6d, 0x61, 0x74, 0x63, 0x68, 0x00, 0x01, 0x01, 0x03, 0x74, 0x79, 0x70, + 0x65, 0x2d, 0x6f, 0x66, 0x00, 0x01, 0x03, 0x62, 0x6f, 0x64, 0x79, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x74, 0x79, 0x70, 0x65, + 0x2d, 0x73, 0x79, 0x6d, 0x62, 0x6f, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x73, + 0x65, 0x74, 0x2d, 0x69, 0x6e, 0x73, 0x65, 0x72, 0x74, 0x00, 0x01, 0x03, + 0x62, 0x6f, 0x64, 0x79, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, + 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, + 0x74, 0x79, 0x70, 0x65, 0x2d, 0x6c, 0x69, 0x73, 0x74, 0x00, 0x01, 0x01, + 0x03, 0x73, 0x65, 0x74, 0x2d, 0x75, 0x6e, 0x69, 0x6f, 0x6e, 0x00, 0x01, + 0x01, 0x03, 0x67, 0x65, 0x74, 0x2d, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, + 0x01, 0x03, 0x63, 0x61, 0x72, 0x00, 0x01, 0x03, 0x62, 0x6f, 0x64, 0x79, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, + 0x01, 0x03, 0x67, 0x65, 0x74, 0x2d, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, + 0x01, 0x03, 0x63, 0x64, 0x72, 0x00, 0x01, 0x03, 0x62, 0x6f, 0x64, 0x79, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, + 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, + 0x5f, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x08, 0x00, 0x00, 0x00, 0x70, 0x69, 0x63, + 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0xfb, 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, + 0x6c, 0x6f, 0x73, 0x75, 0x72, 0x65, 0x00, 0x01, 0x01, 0x03, 0x76, 0x61, + 0x72, 0x73, 0x00, 0x01, 0x03, 0x65, 0x6e, 0x76, 0x00, 0x03, 0x6e, 0x69, + 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, 0x61, 0x74, 0x63, 0x68, 0x00, 0x01, + 0x03, 0x65, 0x6e, 0x76, 0x00, 0x01, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, + 0x01, 0x01, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x62, 0x00, 0x03, 0x6e, + 0x69, 0x6c, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x62, 0x73, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, 0x65, 0x6d, 0x62, + 0x65, 0x72, 0x00, 0x01, 0x03, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, 0x01, + 0x03, 0x63, 0x61, 0x72, 0x00, 0x01, 0x03, 0x62, 0x00, 0x03, 0x6e, 0x69, + 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x63, 0x6f, + 0x6e, 0x73, 0x00, 0x01, 0x03, 0x62, 0x00, 0x01, 0x01, 0x03, 0x70, 0x69, + 0x63, 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0x00, 0x01, 0x03, 0x76, 0x61, 0x72, + 0x73, 0x00, 0x01, 0x03, 0x62, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, + 0x01, 0x03, 0x5f, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x62, 0x73, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x70, 0x69, 0x63, + 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0x00, 0x01, 0x03, 0x76, 0x61, 0x72, 0x73, + 0x00, 0x01, 0x03, 0x62, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, + 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x6e, + 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x0c, 0x00, 0x00, 0x00, + 0x63, 0x6c, 0x65, 0x61, 0x6e, 0x2d, 0x63, 0x6c, 0x2d, 0x65, 0x6e, 0x76, + 0x8b, 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x73, 0x75, 0x72, + 0x65, 0x00, 0x01, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x00, 0x03, 0x6e, 0x69, + 0x6c, 0x00, 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, 0x69, 0x78, 0x00, 0x01, + 0x03, 0x63, 0x6c, 0x6f, 0x00, 0x01, 0x05, 0x00, 0x00, 0x00, 0x03, 0x01, + 0x01, 0x03, 0x70, 0x69, 0x63, 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0x00, 0x01, + 0x01, 0x03, 0x67, 0x65, 0x74, 0x2d, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, + 0x01, 0x03, 0x69, 0x78, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x00, 0x01, + 0x05, 0x00, 0x00, 0x00, 0x02, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, + 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x69, 0x78, 0x00, 0x01, 0x03, 0x63, + 0x6c, 0x6f, 0x00, 0x01, 0x05, 0x00, 0x00, 0x00, 0x03, 0x03, 0x6e, 0x69, + 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00 +}; +unsigned int clean_cl_env_len = 1103; diff --git a/repl/repl.c b/repl/repl.c index 1431eba3..4672fe88 100644 --- a/repl/repl.c +++ b/repl/repl.c @@ -42,6 +42,8 @@ #include "repl_exts.h" #include "repl_defines.h" +#include "clean_cl.h" + #define GC_STACK_SIZE 256 #define PRINT_STACK_SIZE 256 @@ -62,6 +64,8 @@ bool terminate_after_startup = false; volatile lbm_cid startup_cid = -1; volatile lbm_cid store_result_cid = -1; volatile bool silent_mode = false; +bool load_lib_clean_cl = false; + void shutdown_procedure(void); @@ -241,7 +245,7 @@ void print_ctx_info(eval_context_t *ctx, void *arg1, void *arg2) { char output[1024]; int print_ret = lbm_print_value(output, 1024, ctx->r); - if (!silent_mode) { + if (!silent_mode) { printf("--------------------------------\n"); printf("ContextID: %"PRI_UINT"\n", ctx->id); printf("Stack SP: %"PRI_UINT"\n", ctx->K.sp); @@ -305,6 +309,7 @@ lbm_const_heap_t const_heap; #define STORE_RESULT 0x0403 #define TERMINATE 0x0404 #define SILENT_MODE 0x0405 +#define LOAD_LIB_CLEAN_CL 0x0406 struct option options[] = { {"help", no_argument, NULL, 'h'}, @@ -315,6 +320,7 @@ struct option options[] = { {"store_res", required_argument, NULL, STORE_RESULT}, {"terminate", no_argument, NULL, TERMINATE}, {"silent", no_argument, NULL, SILENT_MODE}, + {"lib_clean_cl", no_argument, NULL, LOAD_LIB_CLEAN_CL}, {0,0,0,0}}; typedef struct src_list_s { @@ -380,6 +386,7 @@ void parse_opts(int argc, char **argv) { printf(" --terminate Terminate the REPL after evaluating the\n"\ " source files specified with --src/-s\n"); printf(" --silent The REPL will print as little as possible\n"); + printf(" --lib_clean_cl Load the clean_cl library for closure cleaning\n"); printf("\n"); printf("Multiple sourcefiles can be added with multiple uses of the --src/-s flag.\n" \ "Multiple sources are evaluated in sequence in the order they are specified\n" \ @@ -403,14 +410,79 @@ void parse_opts(int argc, char **argv) { break; case TERMINATE: terminate_after_startup = true; + break; case SILENT_MODE: silent_mode = true; + break; + case LOAD_LIB_CLEAN_CL: + load_lib_clean_cl=true; + break; default: break; } } } +uint32_t read_word(unsigned char *data, unsigned int pos) { + + uint32_t res = 0; + res |= (data[pos]); + res |= ((uint32_t)(data[pos+1]) << 8); + res |= ((uint32_t)(data[pos+2]) << 16); + res |= ((uint32_t)(data[pos+3]) << 24); + return res; +} + +bool load_flat_library(unsigned char *lib, unsigned int size) { + + unsigned int pos = 0; + + while (pos < (size - 1) ) { + uint32_t name_size = read_word(lib,pos); pos += 4; + char *name = malloc(name_size+1); + if (name == NULL) return false; + memset(name, 0, name_size + 1); + memcpy(name, lib + pos, name_size); + pos += name_size; + + lbm_uint sym_id = 0; + if (!lbm_get_symbol_by_name(name, &sym_id)) { + if (!lbm_add_symbol(name, &sym_id)) { + printf("unable to add symbol\n"); + return false; + } + } + free(name); + lbm_value sym = lbm_enc_sym(sym_id); + + uint32_t val_size = read_word(lib, pos); pos += 4; + + lbm_flat_value_t fv; + fv.buf = &lib[pos]; + fv.buf_size = val_size; + fv.buf_pos = 0; + + lbm_value val = ENC_SYM_NIL; + if (!lbm_unflatten_value(&fv, &val)) { + printf("Unable to unflatten value\n"); + return false; + } + + pos += val_size; + + lbm_uint ix_key = sym_id & GLOBAL_ENV_MASK; + lbm_value *global_env = lbm_get_global_env(); + lbm_uint orig_env = global_env[ix_key]; + lbm_value new_env; + + // All of this should just succeed with no GC needed. + new_env = lbm_env_set(orig_env,sym,val); + + global_env[ix_key] = new_env; + } + return true; +} + int init_repl() { if (lispbm_thd && lbm_get_eval_state() != EVAL_CPS_STATE_DEAD) { @@ -461,6 +533,14 @@ int init_repl() { init_exts(); + /* Load clean_cl library into heap */ + if (load_lib_clean_cl) { + if (!load_flat_library(clean_cl_env, clean_cl_env_len)) { + printf("Error loading a flat library\n"); + return 1; + } + } + if (pthread_create(&lispbm_thd, NULL, eval_thd_wrapper, NULL)) { printf("Error creating evaluation thread\n"); return 1; diff --git a/repl/repl_exts.c b/repl/repl_exts.c index 099c8a12..00362a70 100644 --- a/repl/repl_exts.c +++ b/repl/repl_exts.c @@ -457,9 +457,41 @@ static lbm_value ext_fwrite_str(lbm_value *args, lbm_uint argn) { } } return res; - } +static lbm_value ext_fwrite_value(lbm_value *args, lbm_uint argn) { + lbm_value res = ENC_SYM_TERROR; + if (argn == 2 && + is_file_handle(args[0])) { + res = ENC_SYM_NIL; + lbm_file_handle_t *h = (lbm_file_handle_t*)lbm_get_custom_value(args[0]); + + lbm_set_max_flatten_depth(10000); + int32_t fv_size = flatten_value_size(args[1], 0); + if (fv_size > 0) { + lbm_flat_value_t fv; + fv.buf = malloc((uint32_t)fv_size); + if (fv.buf) { + fv.buf_size = (uint32_t)fv_size; + fv.buf_pos = 0; + if (flatten_value_c(&fv, args[1]) == FLATTEN_VALUE_OK) { + fwrite(fv.buf, 1, (size_t)fv_size, h->fp); + fflush(h->fp); + res = ENC_SYM_TRUE; + } else { + printf("ALERT: Unable to flatten result value\n"); + } + } else { + printf("ALERT: Out of memory to allocate result buffer\n"); + } + } else { + printf("ALERT: Incorrect FV size: %d \n", fv_size); + } + } + return res; +} + + static bool all_arrays(lbm_value *args, lbm_uint argn) { bool r = true; for (uint32_t i = 0; i < argn; i ++) { @@ -530,6 +562,7 @@ int init_exts(void) { lbm_add_extension("fopen", ext_fopen); lbm_add_extension("fwrite", ext_fwrite); lbm_add_extension("fwrite-str", ext_fwrite_str); + lbm_add_extension("fwrite-value", ext_fwrite_value); lbm_add_extension("print", ext_print); lbm_add_extension("systime", ext_systime); lbm_add_extension("secs-since", ext_secs_since); diff --git a/src/eval_cps.c b/src/eval_cps.c index 809e9579..337d474e 100644 --- a/src/eval_cps.c +++ b/src/eval_cps.c @@ -1752,6 +1752,21 @@ static void eval_define(eval_context_t *ctx) { error_at_ctx(ENC_SYM_EERROR, ctx->curr_exp); } + +/* Eval lambda is cheating, a lot! It does this + for performance reasons. The cheats are that + 1. When closure is created, a reference to the local env + in which the lambda was evaluated is added to the closure. + Ideally it should have created a list of free variables in the function + and then looked up the values of these creating a new environment. + 2. The global env is considered global constant. As there is no copying + of environment bindings into the closure, undefine may break closures. + + Correct closure creation is a lot more expensive than what happens here. + However, one can try to write programs in such a way that closures are created + seldomly. If one does that the space-usage benefits of "correct" closures + may outweigh the performance gain of "incorrect" ones. + */ // (lambda param-list body-exp) -> (closure param-list body-exp env) static void eval_lambda(eval_context_t *ctx) { lbm_value cdr = get_cdr(ctx->curr_exp); @@ -1921,6 +1936,7 @@ static void eval_var(eval_context_t *ctx) { lbm_value v_exp = get_cadr(args); stack_push_3(&ctx->K, new_env, key, PROGN_VAR); + ctx->curr_env = new_env; // So binding body knows binding (enables recursion) ctx->curr_exp = v_exp; return; } diff --git a/src/fundamental.c b/src/fundamental.c index 5bd65655..ff808d09 100644 --- a/src/fundamental.c +++ b/src/fundamental.c @@ -1317,6 +1317,24 @@ static lbm_value fundamental_drop(lbm_value *args, lbm_uint nargs, eval_context_ return lbm_list_drop(lbm_dec_as_u32(args[1]), args[0]); } +static lbm_value fundamental_member(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { + (void) ctx; + lbm_value res = ENC_SYM_TERROR; + if (nargs == 2 && lbm_is_list(args[0])) { + res = ENC_SYM_NIL; + lbm_value curr = args[0]; + + while (lbm_is_cons(curr)) { + if (struct_eq(lbm_car(curr), args[1])) { + res = args[0]; + break; + } + curr = lbm_cdr(curr); + } + } + return res; +} + const fundamental_fun fundamental_table[] = {fundamental_add, fundamental_sub, @@ -1376,4 +1394,5 @@ const fundamental_fun fundamental_table[] = fundamental_reg_event_handler, fundamental_take, fundamental_drop, + fundamental_member, }; diff --git a/src/symrepr.c b/src/symrepr.c index 03243afd..19ce42e7 100644 --- a/src/symrepr.c +++ b/src/symrepr.c @@ -210,6 +210,7 @@ special_sym const special_symbols[] = { {"event-register-handler", SYM_REG_EVENT_HANDLER}, {"take" , SYM_TAKE}, {"drop" , SYM_DROP}, + {"member" , SYM_MEMBER}, // fast access in list {"ix" , SYM_IX}, diff --git a/tests/test_member_1.lisp b/tests/test_member_1.lisp new file mode 100644 index 00000000..94a997fc --- /dev/null +++ b/tests/test_member_1.lisp @@ -0,0 +1,6 @@ + + +;; Check is pretty serious about t and nil +(check (eq (list 1 2 3) (and (member (list 1 2 3) 2) + (member (list 1 2 3) 3) + (member (list 1 2 3) 1)))) diff --git a/tests/test_member_2.lisp b/tests/test_member_2.lisp new file mode 100644 index 00000000..e049dee2 --- /dev/null +++ b/tests/test_member_2.lisp @@ -0,0 +1,2 @@ + +(check (eq nil (member (list 1 2 3) 4))) diff --git a/tests/test_member_3.lisp b/tests/test_member_3.lisp new file mode 100644 index 00000000..8f5a04c4 --- /dev/null +++ b/tests/test_member_3.lisp @@ -0,0 +1 @@ +(check (eq nil (member '() 1))) diff --git a/tests/test_progn_var_10.lisp b/tests/test_progn_var_10.lisp new file mode 100644 index 00000000..704db2c0 --- /dev/null +++ b/tests/test_progn_var_10.lisp @@ -0,0 +1,8 @@ + + +(progn + (var f (lambda (x) ( + x 1))) + (var a 1) + (check ( = (f a) 2)) + ) + diff --git a/tests/test_progn_var_11.lisp b/tests/test_progn_var_11.lisp new file mode 100644 index 00000000..f211ef65 --- /dev/null +++ b/tests/test_progn_var_11.lisp @@ -0,0 +1,9 @@ + +(progn + (var f (lambda (x) + (if (= 0 x) 0 + (+ x (f (- x 1)))))) + + (var a 10) + (check ( = (f a) 55)) + )