rusefi
/
bldc
mirror of https://github.com/rusefi/bldc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Merge commit '85ee6ead0306844c2a05f4b205479d0be4272d0c'

This commit is contained in:
Benjamin Vedder 2022-07-06 10:18:45 +02:00
parent f53cbfce75 85ee6ead03
commit 035d3b1078
61 changed files with 4237 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
lispBM/lispBM/README.md
View File

@ -1,4 +1,4 @@
# lispBM (Lisp Black Magic)
# lispBM (LBM)
A concurrent lisp-like language with message-passing and
pattern-matching implemented in C for 32 bit and 64 bit platforms.
@ -46,31 +46,6 @@ All programming languages need a mascot, so here is the LispBM llama by [PixiLad
3. Then join in the fun. Lots to do, so little time!
4. Poke me by mail bo(dot)joel(dot)svensson(whirly-a)gmail(dot)com
## TODOs
1. [x] Write some tests that stresses the Garbage collector.
2. [x] Implement some "reference to X type", for uint32, int32.
3. [x] Write a small library of useful hofs.
4. [x] Improve handling of arguments in eval-cps.
5. [x] Code improvements with simplicity, clarity and readability in mind.
6. [x] Implement a small dedicated lisp reader/parser to replace MPC. MPC eats way to much memory for small platforms.
7. [x] Port to STM32f4 - 128K ram platform (will need big changes). (surely there will be some more bugs)
8. [x] Add STM32f4 example code (repl implementation)
9. [x] Port to nrf52840_pca10056 - 256k ram platform (same changes as above).
10. [x] Reduce size of builtins.c and put platform specific built in functions elsewhere. (Builtins.c will be removed an replaced by fundamentals.c)
11. [x] Implement 'progn' facility.
12. [x] Remove the "gensym" functionality havent found a use for it so far and it only complicates things.
13. [x] Add NRF52 example repl to repository
14. [x] Update all example REPLs after adding quasiquotation
15. [x] The parser allocates heap memory, but there is no interfacing with the GC there.
16. [x] The parser uses a lot of stack memory, fix by making tail recursive and accumulating lists onto heap directly.
17. [x] Rename files with names that may conflict with common stuff (memory.h, memory.c).
18. [x] It should be possible to reset the runtime system.
19. [x] Add messages to lisp process mailbox from C to unlock blocked proc.
20. [x] Spawn closures specifically instead of expressions in general.
21. [x] Implement some looping structure for speed or just ease of use.
See the loop macros implemented by Benjamin in [bldc](https://github.com/vedderb/bldc/blob/master/lispBM/lispif_vesc_dynamic_loader.c#L103).
## Vague or continuosly ongoing todos
1. Doxygen?
2. Tutorials?
@ -79,7 +54,6 @@ All programming languages need a mascot, so here is the LispBM llama by [PixiLad
5. More built in comparisons.
6. Make uniform how to return success or failure. It is sometimes bool and sometimes int right now.
## Compile a 32bit binary for linux (Requires 32bit libraries. May need something like "multilib" on a 64bit linux)
1. Build the repl: `cd repl-cps` and then `make`
@ -109,3 +83,14 @@ make pirepl
Then start it up using `./repl`
Building the library is not a prerequisite for building the repl anymore.
## SDL and LispBM
In the `sdlrepl` directory there is a start of a set of SDL bindings for LispBM.
To build this repl you need the following dependencies:
1. libsdl2-dev - `sudo apt-get install libsdl2-dev`
2. libsdl2-image-dev - `sudo apt-get install libsdl2-image-dev`
Then compile the repl using the command `make`

1
lispBM/lispBM/benchmarks/bench_chibi/Makefile
View File

@ -138,6 +138,7 @@ LBMSRC = ../../src/compression.c \
../../src/lispbm.c \
../../src/lbm_c_interop.c \
../../src/lbm_variables.c \
../../src/lbm_custom_type.c \
../../platform/chibios/src/platform_mutex.c
CSRC = $(ALLCSRC) \

2
lispBM/lispBM/chibios-examples/repl-ChibiOS/Makefile
View File

@ -129,7 +129,6 @@ LBMSRC = ../../src/compression.c \
../../src/fundamental.c \
../../src/heap.c \
../../src/lbm_memory.c \
../../src/prelude.c \
../../src/print.c \
../../src/qq_expand.c \
../../src/stack.c \
@ -139,6 +138,7 @@ LBMSRC = ../../src/compression.c \
../../src/lispbm.c \
../../src/lbm_c_interop.c \
../../src/lbm_variables.c \
../../src/lbm_custom_type.c \
../../platform/chibios/src/platform_mutex.c
CSRC = $(ALLCSRC) \

22
lispBM/lispBM/chibios-examples/repl-ChibiOS/main.c
View File

@ -35,12 +35,14 @@
#define GC_STACK_SIZE 256
#define PRINT_STACK_SIZE 256
#define HEAP_SIZE 2048
#define VARIABLE_STORAGE_SIZE 256
#define EXTENSION_STORAGE_SIZE 256
#define WAIT_TIMEOUT 2500
uint32_t gc_stack_storage[GC_STACK_SIZE];
uint32_t print_stack_storage[PRINT_STACK_SIZE];
lbm_value variable_storage[VARIABLE_STORAGE_SIZE];
extension_fptr extension_storage[EXTENSION_STORAGE_SIZE];
static lbm_cons_t heap[HEAP_SIZE] __attribute__ ((aligned (8)));
@ -212,6 +214,8 @@ int main(void) {
lbm_set_timestamp_us_callback(timestamp_callback);
lbm_set_usleep_callback(sleep_callback);
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
res = lbm_add_extension("print", ext_print);
if (res)
chprintf(chp,"Extension added.\r\n");
@ -323,24 +327,6 @@ int main(void) {
lbm_add_extension("print", ext_print);
} else if (strncmp(str, ":prelude", 8) == 0) {
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
chThdSleepMilliseconds(1);
}
prelude_load(&string_tok_state,
&string_tok);
lbm_cid cid = lbm_load_and_eval_program(&string_tok);
lbm_continue_eval();
if (!lbm_wait_ctx((lbm_cid)cid, WAIT_TIMEOUT)) {
chprintf(chp,"Wait for prelude to load timed out.\r\n");
} else {
chprintf(chp,"Prelude loaded.\r\n");
}
} else if (strncmp(str, ":quit", 5) == 0) {
break;

2
lispBM/lispBM/chibios-examples/xmas_dac/Makefile
View File

@ -129,7 +129,6 @@ LBMSRC = ../../src/env.c \
../../src/fundamental.c \
../../src/heap.c \
../../src/lbm_memory.c \
../../src/prelude.c \
../../src/print.c \
../../src/qq_expand.c \
../../src/stack.c \
@ -139,6 +138,7 @@ LBMSRC = ../../src/env.c \
../../src/lispbm.c \
../../src/lbm_c_interop.c \
../../src/lbm_variables.c \
../../src/lbm_custom_type.c \
../../platform/chibios/src/platform_mutex.c
CSRC = $(ALLCSRC) \

17
lispBM/lispBM/chibios-examples/xmas_dac/main.c
View File

@ -360,23 +360,6 @@ int main(void) {
return 1;
}
prelude_load(&string_tok_state,
&string_tok);
lbm_cid cid = lbm_load_and_eval_program(&string_tok);
chprintf(chp,"whats going on here\n");
if (!lbm_wait_ctx(cid, WAIT_TIMEOUT)) {
chprintf(chp,"Wait for prelude to load timed out\r\n");
} else {
chprintf(chp,"Prelude loaded!\r\n");
}
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
chprintf(chp,"pause sleeping\n");
sleep_callback(1000);
}
lbm_continue_eval();
chprintf(chp,"Lisp REPL started (ChibiOS)!\r\n");
while (1) {

47
lispBM/lispBM/doc/lbmref.md
View File

@ -1,5 +1,49 @@
# LispBM language reference
## About Symbols
Symbols are very important and fundamental to LispBM and also perhaps
a bit different from identifiers/names used in languages such as C, so
a short intro could be good here.
A symbol can be thought of as a name and can be used to give names
to functions or values (variables). A symbol can also be treated and
used as a value in and of itself a value (or data). So it can be used
to name data and functions and is itself also data.
---
**NOTE**
Symbols are expressed as strings in your program such as `a`, `let`,
`define`, `+` or `orange`. The "reader", the part of LBM that parses
code, translates each symbol into a 28bit value. The string `orange`
for example is only of interest if you print a symbol and then the
runtime system will look up what string corresponds to the 28bit
identifier you want to print. So the runtime system is never wasting
time comparing strings to see if a symbol is this or that symbol, it's
all integer comparisons.
---
You associate values with symbols using, <a href="#define">define</a>,
<a href="#let">let</a> and you can change the value bound to a "variable"
using <a href="#setvar">setvar</a>
Not all symbols are treated the same in LBM. Some symbols are treated as
special because of their very fundamental nature. Among these special symbols
you find `define`, `let` and `lambda` for example. These are things that you
should not be able to redefine and trying to redefine them leads to an error.
There are two classes of symbols that are special by naming convention and
these either start with a `#`, for fast-lookup variables, and `ext-` for
extensions that will be bound at runtime.
Examples of symbols used as data are `nil` and `t`. `nil` is used the
represent nothing, the empty list or other similar things and `t`
represents true. But any symbol can be used as data by quoting it
`'`, see <a href="#quotes-and-quasiquotation"> Quotes and
Quasiquotation </a>.
## Arithmetic
### +
@ -663,7 +707,7 @@ And you can change the value of a `#var`.
```clj
(define #a 10)
(set '#a 20)
(setvar '#a 20)
```
`#a` is now 20.
@ -1271,7 +1315,6 @@ Below is an example that conditionally returns.
---
## Unparsable symbols
Unparsable symbols cannot be written into a program. The unparsable symbols

25
lispBM/lispBM/doc/manual/ch1_introduction.md
View File

@ -1,18 +1,18 @@
# Chapter 1: Introduction to programming in LispBM
LispBM (from now on called LBM) is a lisp dialect that was implemented
LispBM (from now on called LBM) is a Lisp dialect that was implemented
to be run on small resource constrained systems. The look-and-feel of
LispBM has been very much influenced by the series of videos based on
LBM has been very much influenced by the series of videos based on
the SICP book (Structure and Interpretation of Computer Programs) by
Harold Abelson, Gerald Jay Sussman and Julie Sussman. The awesome
series of videos about lisp programming can be found
series of videos about Lisp programming can be found
[here](https://www.youtube.com/playlist?list=PL8FE88AA54363BC46). Note
that LBM is not 100% compatible with all code you see in the video series
but this is quite OK, there are many slightly different flavors of lisps.
that LBM is not 100% compatible with the code you see in the video series
but this is quite OK, there are many slightly different flavors of Lisps.
LBM itself implements the concurrency, communication and a basic set
of lisp functionality such as arithmetic. The idea with LBM is that it
of Lisp functionality such as arithmetic. The idea with LBM is that it
should be embedded into some other embedded system, or other,
application and functionality specific to that application is exposed
to LBM via so-called extensions. As a result of that it is for example
@ -412,6 +412,19 @@ is bound to that symbol) more efficient. So, symbols should not start with
that you are going to use a lot and where efficiency will matter a lot.
---
**NOTE**
Symbols starting with `ext-` are allocated in the table of extensions.
This means that you should not create symbols starting with `ext-`
unless you are going to associate that symbol with an
extension. Currently the only way to associate an `ext-` symbol with
an extension is by using the dynamic native code loader in the [VESC
flavor](https://github.com/vedderb/bldc/tree/master/lispBM) of LBM.
In the VESC LBM, loading of these dynamic extensions is done via an
extension called `load-native-lib`.
---
### An important concept with an unremarkable name: Quote

8
lispBM/lispBM/esp-examples/repl/CMakeLists.txt Normal file
View File

@ -0,0 +1,8 @@
# The following lines of boilerplate have to be in your project's
# CMakeLists in this exact order for cmake to work correctly
cmake_minimum_required(VERSION 3.5)
include($ENV{IDF_PATH}/tools/cmake/project.cmake)
get_filename_component(ProjectId ${CMAKE_CURRENT_LIST_DIR} NAME)
string(REPLACE " " "_" ProjectId ${ProjectId})
project(${ProjectId})

24
lispBM/lispBM/esp-examples/repl/main/CMakeLists.txt Normal file
View File

@ -0,0 +1,24 @@
idf_component_register(SRCS "main.c"
"../../../src/heap.c"
"../../../src/env.c"
"../../../src/eval_cps.c"
"../../../src/extensions.c"
"../../../src/fundamental.c"
"../../../src/symrepr.c"
"../../../src/lispbm.c"
"../../../src/lbm_memory.c"
"../../../src/lbm_variables.c"
"../../../src/lbm_c_interop.c"
"../../../src/lbm_custom_type.c"
"../../../src/print.c"
"../../../src/qq_expand.c"
"../../../src/stack.c"
"../../../src/streams.c"
"../../../src/tokpar.c"
"../../../platform/freertos/src/platform_mutex.c"
"../../../src/extensions/array_extensions.c"
"../../../src/extensions/math_extensions.c"
"../../../src/extensions/string_extensions.c"
INCLUDE_DIRS ""
"../../../include"
"../../../platform/freertos/include")

375
lispBM/lispBM/esp-examples/repl/main/main.c Normal file
View File

@ -0,0 +1,375 @@
/*
Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#include <stdio.h>
#include <stdarg.h>
#include <ctype.h>
#include "sdkconfig.h"
#include "freertos/FreeRTOS.h"
#include "freertos/task.h"
#include "esp_chip_info.h"
#include "esp_spi_flash.h"
#include "driver/uart.h"
#include "lispbm.h"
#include "lbm_llama_ascii.h"
#include "lbm_version.h"
#include "extensions/array_extensions.h"
#include "extensions/string_extensions.h"
#include "extensions/math_extensions.h"
#include "lbm_custom_type.h"
#define UART_NUM 0
#define UART_BAUDRATE 115200
#define UART_TX 21
#define UART_RX 20
void uart_init(void) {
uart_config_t uart_config = {
.baud_rate = UART_BAUDRATE,
.data_bits = UART_DATA_8_BITS,
.parity = UART_PARITY_DISABLE,
.stop_bits = UART_STOP_BITS_1,
.flow_ctrl = UART_HW_FLOWCTRL_DISABLE,
.source_clk = UART_SCLK_DEFAULT,
};
uart_driver_install(UART_NUM, 512, 512, 0, 0, 0);
uart_param_config(UART_NUM, &uart_config);
uart_set_pin(UART_NUM, UART_TX, UART_RX, -1, -1);
}
int get_char(void) {
uint8_t c;
int r = 0;
do {
r = uart_read_bytes(UART_NUM, &c, 1, portMAX_DELAY);
} while (r == 0);
return (int)c;
}
void uart_printf(const char* fmt, ...) {
char buffer[256];
va_list args;
va_start (args, fmt);
int n = vsnprintf (buffer,256,fmt, args);
va_end (args);
if (n > 0) {
uart_write_bytes(UART_NUM, buffer, n);
}
}
void put_char(char c) {
uart_write_bytes(UART_NUM, &c, 1);
}
int inputline(char *buffer, int size) {
int n = 0;
unsigned char c;
for (n = 0; n < size - 1; n++) {
c = get_char();
switch (c) {
case 127: /* fall through to below */
case '\b': /* backspace character received */
if (n > 0)
n--;
buffer[n] = 0;
put_char(0x8); /* output backspace character */
put_char(' ');
put_char(0x8);
n--; /* set up next iteration to deal with preceding char location */
break;
case '\n': /* fall through to \r */
case '\r':
buffer[n] = 0;
return n;
default:
if (isprint(c)) { /* ignore non-printable characters */
put_char(c);
buffer[n] = c;
} else {
n -= 1;
}
break;
}
}
buffer[size - 1] = 0;
return 0; // Filled up buffer without reading a linebreak
}
#define EVAL_CPS_STACK_SIZE 256
#define GC_STACK_SIZE 256
#define PRINT_STACK_SIZE 256
#define EXTENSION_STORAGE_SIZE 256
#define VARIABLE_STORAGE_SIZE 256
#define WAIT_TIMEOUT 2500
#define STR_SIZE 1024
#define HEAP_SIZE 2048
#define PRINT_SIZE 1024
lbm_uint gc_stack_storage[GC_STACK_SIZE];
lbm_uint print_stack_storage[PRINT_STACK_SIZE];
extension_fptr extension_storage[EXTENSION_STORAGE_SIZE];
lbm_value variable_storage[VARIABLE_STORAGE_SIZE];
static lbm_cons_t heap[HEAP_SIZE] __attribute__ ((aligned (8)));
static lbm_uint memory[LBM_MEMORY_SIZE_8K];
static lbm_uint bitmap[LBM_MEMORY_BITMAP_SIZE_8K];
static lbm_tokenizer_string_state_t string_tok_state;
static lbm_tokenizer_char_stream_t string_tok;
static char print_output[PRINT_SIZE];
void eval_thd_wrapper(void *v) {
lbm_run_eval();
}
void done_callback(eval_context_t *ctx) {
char *output = print_output;
lbm_cid cid = ctx->id;
lbm_value t = ctx->r;
int print_ret = lbm_print_value(output, PRINT_SIZE, t);
if (print_ret >= 0) {
uart_printf("<< Context %d finished with value %s >>\r\n", cid, output);
} else {
uart_printf("<< Context %d finished with value %s >>\r\n", cid, output);
}
}
// On FreeRTOS the systick freq can be set to at most 1KHz.
// At 1KHz, 1 tick is 1000 us.
uint32_t timestamp_callback(void) {
TickType_t t = xTaskGetTickCount();
return (uint32_t) (1000 * t);
}
void sleep_callback(uint32_t us) {
uint32_t ticks = us / 1000;
if (ticks == 0) vTaskDelay(1);//taskYIELD();
else vTaskDelay(ticks);
}
lbm_value ext_print(lbm_value *args, lbm_uint argn) {
char *output = print_output;
for (lbm_uint i = 0; i < argn; i ++) {
lbm_value t = args[i];
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(t);
switch (array->elt_type){
case LBM_TYPE_CHAR:
uart_printf("%s", (char*)array->data);
break;
default:
return lbm_enc_sym(SYM_NIL);
break;
}
} else if (lbm_type_of(t) == LBM_TYPE_CHAR) {
if (lbm_dec_char(t) =='\n') {
uart_printf("\r\n");
} else {
uart_printf("%c", lbm_dec_char(t));
}
} else {
lbm_print_value(output, 1024, t);
uart_printf("%s", output);
}
}
return lbm_enc_sym(SYM_TRUE);
}
static char outbuf[1024];
void print_ctx_info(eval_context_t *ctx, void *arg1, void *arg2) {
(void)arg2;
lbm_print_value(outbuf, 1024, ctx->r);
uart_printf("%s %x %u %u %s\r\n", (char*)arg1, (uint32_t)ctx, ctx->id, ctx->K.sp, outbuf);
}
void ctx_exists(eval_context_t *ctx, void *arg1, void *arg2) {
lbm_cid id = *(lbm_cid*)arg1;
bool *exists = (bool*)arg2;
if (ctx->id == id) {
*exists = true;
}
}
static char str[1024];
static char outbuf[1024];
void app_main(void)
{
int res = 0;
lbm_heap_state_t heap_state;
vTaskDelay(1000);
uart_init();
if (!lbm_init(heap, HEAP_SIZE,
gc_stack_storage, GC_STACK_SIZE,
memory, LBM_MEMORY_SIZE_8K,
bitmap, LBM_MEMORY_BITMAP_SIZE_8K,
print_stack_storage, PRINT_STACK_SIZE,
extension_storage, EXTENSION_STORAGE_SIZE)) {
uart_printf("LispBM Init failed.\r\n");
return;
}
uart_printf("LispBM Initialized\r\n");
lbm_set_ctx_done_callback(done_callback);
lbm_set_timestamp_us_callback(timestamp_callback);
lbm_set_usleep_callback(sleep_callback);
res = lbm_add_extension("print", ext_print);
if (res)
uart_printf("Extension added.\r\n");
else
uart_printf("Error adding extension.\r\n");
TaskHandle_t eval_thd = NULL;
BaseType_t status = xTaskCreate(eval_thd_wrapper,
"eval",
4096,
NULL,
2,
&eval_thd
);
if( status == pdPASS ) {
uart_printf("Evaluator thread started\r\n");
}
uart_printf("LispBM Version %d.%d.%d\r\n", LBM_MAJOR_VERSION, LBM_MINOR_VERSION, LBM_PATCH_VERSION);
uart_printf("Lisp REPL started (ESP32C3)\r\n");
while (1) {
uart_printf("# ");
memset(str,0,1024);
memset(outbuf,0, 1024);
inputline(str, 1024);
uart_printf("\r\n");
if (strncmp(str, ":info", 5) == 0) {
uart_printf("------------------------------------------------------------\r\n");
uart_printf("Used cons cells: %lu \r\n", HEAP_SIZE - lbm_heap_num_free());
uart_printf("Free cons cells: %lu\r\n", lbm_heap_num_free());
lbm_get_heap_state(&heap_state);
uart_printf("GC counter: %lu\r\n", heap_state.gc_num);
uart_printf("Recovered: %lu\r\n", heap_state.gc_recovered);
uart_printf("Marked: %lu\r\n", heap_state.gc_marked);
uart_printf("Array and symbol string memory:\r\n");
uart_printf(" Size: %u 32Bit words\r\n", lbm_memory_num_words());
uart_printf(" Free: %u 32Bit words\r\n", lbm_memory_num_free());
uart_printf("------------------------------------------------------------\r\n");
memset(outbuf,0, 1024);
} else if (strncmp(str, ":env", 4) == 0) {
lbm_value curr = *lbm_get_env_ptr();
uart_printf("Environment:\r\n");
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
res = lbm_print_value(outbuf,1024, lbm_car(curr));
curr = lbm_cdr(curr);
uart_printf(" %s \r\n", outbuf);
}
} else if (strncmp(str, ":ctxs", 5) == 0) {
lbm_running_iterator(print_ctx_info, "RUNNABLE", NULL);
lbm_blocked_iterator(print_ctx_info, "BLOCKED", NULL);
lbm_done_iterator (print_ctx_info, "DONE", NULL);
} else if (strncmp(str, ":wait", 5) == 0) {
int id = atoi(str + 5);
bool exists = false;
lbm_done_iterator(ctx_exists, (void*)&id, (void*)&exists);
if (exists) {
lbm_wait_ctx((lbm_cid)id, WAIT_TIMEOUT);
}
} else if (strncmp(str, ":pause", 6) == 0) {
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
uart_printf("Evaluator paused\r\nEnter command :continue to unpause or :step to perform single stepping\r\n");
} else if (strncmp(str, ":continue", 9) == 0) {
lbm_continue_eval();
} else if (strncmp(str, ":step", 5) == 0) {
lbm_step_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(1);
}
uart_printf("Evaluator paused\r\nEnter command :continue to unpause or :step to perform single stepping\r\n");
} else if (strncmp(str, ":reset", 6) == 0) {
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(1);
}
if (!lbm_init(heap, HEAP_SIZE,
gc_stack_storage, GC_STACK_SIZE,
memory, LBM_MEMORY_SIZE_8K,
bitmap, LBM_MEMORY_BITMAP_SIZE_8K,
print_stack_storage, PRINT_STACK_SIZE,
extension_storage, EXTENSION_STORAGE_SIZE)) {
uart_printf("LispBM Init failed.\r\n");
return;
}
lbm_add_extension("print", ext_print);
} else if (strncmp(str, ":quit", 5) == 0) {
break;
} else {
if (strlen(str) == 0) {
continue;
}
/* Get exclusive access to the heap */
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
lbm_create_char_stream_from_string(&string_tok_state,
&string_tok,
str);
lbm_cid cid = lbm_load_and_eval_expression(&string_tok);
lbm_continue_eval();
uart_printf("started ctx: %u\r\n", cid);
lbm_wait_ctx((lbm_cid)cid, WAIT_TIMEOUT);
}
}
}

1522
lispBM/lispBM/esp-examples/repl/sdkconfig Normal file
View File

File diff suppressed because it is too large Load Diff

0
lispBM/lispBM/esp-examples/repl/sdkconfig.ci Normal file
View File

38
lispBM/lispBM/include/heap.h
View File

@ -203,11 +203,12 @@ Aux bits could be used for storing vector size. Up to 30bits should be available
#define LBM_TYPE_U64 0x50000000u
#define LBM_TYPE_FLOAT 0x60000000u
#define LBM_TYPE_DOUBLE 0x70000000u
#define LBM_TYPE_ARRAY 0xD0000000u
#define LBM_TYPE_REF 0xE0000000u
#define LBM_TYPE_STREAM 0xF0000000u
#define LBM_NON_CONS_POINTER_TYPE_LAST 0xF0000000u
#define LBM_POINTER_TYPE_LAST 0xF0000000u
#define LBM_TYPE_ARRAY 0x80000000u
#define LBM_TYPE_REF 0x90000000u
#define LBM_TYPE_STREAM 0xA0000000u
#define LBM_TYPE_CUSTOM 0xB0000000u
#define LBM_NON_CONS_POINTER_TYPE_LAST 0xB0000000u
#define LBM_POINTER_TYPE_LAST 0xB0000000u
#define LBM_GC_MASK 0x00000002u
@ -215,7 +216,7 @@ Aux bits could be used for storing vector size. Up to 30bits should be available
#define LBM_VAL_MASK 0xFFFFFFF0u
#define LBM_VAL_TYPE_MASK 0x0000000Cu
// gc ptr
// gc ptr
#define LBM_TYPE_SYMBOL 0x00000000u // 00 0 0
#define LBM_TYPE_CHAR 0x00000004u // 01 0 0
#define LBM_TYPE_BYTE 0x00000004u
@ -234,15 +235,16 @@ Aux bits could be used for storing vector size. Up to 30bits should be available
#define LBM_POINTER_TYPE_FIRST (lbm_uint)0x1000000000000000
#define LBM_TYPE_CONS (lbm_uint)0x1000000000000000
#define LBM_NON_CONS_POINTER_TYPE_FIRST (lbm_uint)0xA000000000000000
#define LBM_TYPE_U64 (lbm_uint)0xA000000000000000
#define LBM_TYPE_I64 (lbm_uint)0xB000000000000000
#define LBM_TYPE_DOUBLE (lbm_uint)0xC000000000000000
#define LBM_TYPE_ARRAY (lbm_uint)0xD000000000000000
#define LBM_TYPE_REF (lbm_uint)0xE000000000000000
#define LBM_TYPE_STREAM (lbm_uint)0xF000000000000000
#define LBM_NON_CONS_POINTER_TYPE_LAST (lbm_uint)0xF000000000000000
#define LBM_POINTER_TYPE_LAST (lbm_uint)0xF000000000000000
#define LBM_NON_CONS_POINTER_TYPE_FIRST (lbm_uint)0x2000000000000000
#define LBM_TYPE_U64 (lbm_uint)0x2000000000000000
#define LBM_TYPE_I64 (lbm_uint)0x3000000000000000
#define LBM_TYPE_DOUBLE (lbm_uint)0x4000000000000000
#define LBM_TYPE_ARRAY (lbm_uint)0x5000000000000000
#define LBM_TYPE_REF (lbm_uint)0x6000000000000000
#define LBM_TYPE_STREAM (lbm_uint)0x7000000000000000
#define LBM_TYPE_CUSTOM (lbm_uint)0x8000000000000000
#define LBM_NON_CONS_POINTER_TYPE_LAST (lbm_uint)0x8000000000000000
#define LBM_POINTER_TYPE_LAST (lbm_uint)0x8000000000000000
#define LBM_GC_MASK (lbm_uint)0x2
#define LBM_GC_MARKED (lbm_uint)0x2
@ -365,6 +367,12 @@ extern char *lbm_dec_str(lbm_value val);
* \return A pointer to an lbm_stream_t or NULL if the value does not encode a stream.
*/
extern lbm_stream_t *lbm_dec_stream(lbm_value val);
/** Decode an lbm_value representing a custom type into a lbm_uint value.
*
* \param val Value.
* \return The custom type payload.
*/
extern lbm_uint lbm_dec_custom(lbm_value val);
/** Decode a numerical value as if it is char
*
* \param val Value to decode

60
lispBM/lispBM/include/lbm_custom_type.h Normal file
View File

@ -0,0 +1,60 @@
/*
Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
/** \file lbm_custom_type.h */
#ifndef LBM_CUSTOM_TYPE_H_
#define LBM_CUSTOM_TYPE_H_
#include <stdbool.h>
#include <lbm_types.h>
// Custom type lbm_memory footprint
#define CUSTOM_TYPE_VALUE 0
#define CUSTOM_TYPE_DESCRIPTOR 1
#define CUSTOM_TYPE_DESTRUCTOR 2
#define CUSTOM_TYPE_LBM_MEM_SIZE 3
// encoding
//
// ( lbm-mem-ptr . LBM_TYPE_CUSTOM_SYM )
// |
// pointer to lbm_memory
//
typedef bool (*custom_type_destructor)(lbm_uint);
/** Create a value of a custom type with a destructor and a description
*
* \param value The custom value. This can be a pointer to memory allocated
* on the C-side.
* \param fptr The destructor function. This function should free any memory
* allocated on the C-side.
* \param desc A description of the type that will be used for printing.
* \param result Pointer to lbm_value that will hold the value of the custom type.
* \return true on success or false otherwise.
*/
extern bool lbm_custom_type_create(lbm_uint value, custom_type_destructor fptr, const char *desc, lbm_value *result);
/** Called by garbage collector and invokes the destructor
* on the custom value.
*
* /return true on success or false otherwise.
*/
extern bool lbm_custom_type_destroy(lbm_uint *lbm_mem_ptr);
#endif

2
lispBM/lispBM/include/lbm_memory.h
View File

@ -150,7 +150,7 @@ extern int lbm_memory_free(lbm_uint *ptr);
* \param n New smaller size of array
* \return 1 on success and 0 on failure.
*/
extern int lbm_memory_shrink(lbm_uint *ptr, unsigned int n);
extern int lbm_memory_shrink(lbm_uint *ptr, lbm_uint n);
/** Check if a pointer points into the lbm_memory
*

16
lispBM/lispBM/include/lbm_version.h
View File

@ -25,9 +25,23 @@
/** LBM minor version */
#define LBM_MINOR_VERSION 5
/** LBM patch revision */
#define LBM_PATCH_VERSION 3
#define LBM_PATCH_VERSION 4
/*! \page changelog Changelog
Jul 4 2022: Version 0.5.4
- Added possibility to partially apply closures. A partially applied closure
is again a closure.
May 24 2022: Version 0.5.3
- Fixed bug related to float-array literals not accepting whole numbers unless containing a decimal (0).
May 22 2022: Version 0.5.3
- Fixed bug that could cause problems with call-cc on 64bit platforms.
- bind_to_key_rest continuation refactoring to use indexing into stack.
- Fix evaluator bug in progn that made tail-call not fire properly when there
is only one expr in the progn sequence.
May 10 2022: Version 0.5.3
- symbols starting with "ext-" will be allocated into the extensions-list
and can on the VESC version of lispbm be dynamically bound to newly loaded

1
lispBM/lispBM/include/lispbm.h
View File

@ -33,6 +33,7 @@
#include "lbm_types.h"
#include "lbm_c_interop.h"
#include "lbm_variables.h"
#include "lbm_custom_type.h"
/** Initialize lispBM. This function initials all subsystems by calling:
* - \ref lbm_print_init

23
lispBM/lispBM/include/symrepr.h
View File

@ -77,17 +77,18 @@
#define SYM_IND_F_TYPE 0x36
#define SYM_STREAM_TYPE 0x37
#define SYM_BYTECODE_TYPE 0x38
#define TYPE_CLASSIFIER_ENDS 0x38
#define SYM_NONSENSE 0x39
#define SYM_CUSTOM_TYPE 0x39
#define TYPE_CLASSIFIER_ENDS 0x39
#define SYM_NONSENSE 0x3A
#define SYM_NO_MATCH 0x3A
#define SYM_MATCH_ANY 0x3B
#define SYM_MATCH_I 0x3C
#define SYM_MATCH_U 0x3D
#define SYM_MATCH_U32 0x3E
#define SYM_MATCH_I32 0x3F
#define SYM_MATCH_FLOAT 0x40
#define SYM_MATCH_CONS 0x41
#define SYM_NO_MATCH 0x40
#define SYM_MATCH_ANY 0x41
#define SYM_MATCH_I 0x42
#define SYM_MATCH_U 0x43
#define SYM_MATCH_U32 0x44
#define SYM_MATCH_I32 0x45
#define SYM_MATCH_FLOAT 0x46
#define SYM_MATCH_CONS 0x47
// Type identifying symbols
#define SYM_TYPE_LIST 0x50
@ -195,6 +196,8 @@
#define SYM_BITWISE_XOR 0x174
#define SYM_BITWISE_NOT 0x175
#define SYM_CUSTOM_DESTRUCT 0x180 /* run the destructor of a custom type */
#define SYM_TYPE_OF 0x200
#define FUNDAMENTALS_END 0x200

1
lispBM/lispBM/lispbm.mk
View File

@ -16,6 +16,7 @@ LISPBM_SRC = $(LISPBM)/src/env.c \
$(LISPBM)/src/streams.c \
$(LISPBM)/src/lbm_c_interop.c \
$(LISPBM)/src/lbm_variables.c \
$(LISPBM)/src/lbm_custom_type.c \
$(LISPBM)/src/extensions/array_extensions.c \
$(LISPBM)/src/extensions/string_extensions.c \
$(LISPBM)/src/extensions/math_extensions.c

3
lispBM/lispBM/mktags.sh Executable file
View File

@ -0,0 +1,3 @@
#!/bin/bash
ctags -e -R *

31
lispBM/lispBM/platform/freertos/include/platform_mutex.h Normal file
View File

@ -0,0 +1,31 @@
/*
Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#ifndef PLATFORM_MUTEX_H_
#define PLATFORM_MUTEX_H_
#include <freertos/FreeRTOS.h>
#include <freertos/semphr.h>
#include <stdbool.h>
typedef SemaphoreHandle_t mutex_t;
extern bool mutex_init(mutex_t *m);
extern void mutex_lock(mutex_t *m);
extern void mutex_unlock(mutex_t *m);
#endif

34
lispBM/lispBM/platform/freertos/src/platform_mutex.c Normal file
View File

@ -0,0 +1,34 @@
/*
Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#include "platform_mutex.h"
bool mutex_init(mutex_t *m) {
*m = xSemaphoreCreateMutex();
if (*m != NULL)
return true;
return false;
}
void mutex_lock(mutex_t *m) {
xSemaphoreTake(*m, portMAX_DELAY);
}
void mutex_unlock(mutex_t *m) {
xSemaphoreGive(*m);
}

130
lispBM/lispBM/repl/evaldefunc.lisp Normal file
View File

@ -0,0 +1,130 @@
(define global-env 'nil)
(defun is-number (e)
(or (eq (type-of e) type-i)
(eq (type-of e) type-u)))
(defun is-symbol (e)
(eq (type-of e) type-symbol))
(defun is-operator (e)
(or (eq e '+)
(eq e '-)
(eq e '=)
(eq e '*)
))
(defun is-closure (e)
(and (eq (type-of e) type-list)
(eq (car e) 'closure)))
(defun add-bindings (env binds)
(match binds
(nil env)
(((? b) . (? rs))
(add-bindings (setassoc env b) rs))))
(defun eval-progn (env args k)
(match args
(nil (apply-cont k nil))
(((? l) . nil) (evald env l k))
(((? l) . (? ls))
(evald env l
(list 'progn-cont env ls k)))))
(defun eval-define (env args k)
(let ((key (car args))
(val (car (cdr args))))
(evald env val
(list 'define-cont key k))))
(defun eval-lambda (env args k)
(apply-cont k (append (cons 'closure args) (list env))))
(defun eval-if (env args k)
(let ((cond-exp (car args))
(then-branch (car (cdr args)))
(else-branch (car (cdr (cdr args)))))
(evald env cond-exp
(list 'if-cont env then-branch else-branch k))))
(defun eval-list (env ls acc k)
(if (eq ls nil)
(apply-cont k acc)
(let (( l (car ls))
( r (cdr ls)))
(evald env l
(list 'list-cont env r acc k)))))
(defun apply-closure (env ls k)
(let ((clo (car ls))
(args (cdr ls))
(ps (car (cdr clo)))
(body (car (cdr (cdr clo))))
(env1 (car (cdr (cdr (cdr clo)))))
(arg-env (zip ps args))
(new-env (add-bindings (append env1 env) arg-env)))
(evald new-env body k)))
(defun apply (env ls k)
(let ((f (car ls)))
(if (is-operator f)
(apply-cont k (eval ls))
(if (is-closure f)
(apply-closure env ls k)
'error))))
(defun apply-cont (k exp)
(match k
(done exp)
((progn-cont (? env) (? ls) (? k1)) (eval-progn env ls k1))
((define-cont (? key) (? k1))
(progn
(setvar 'global-env (acons key exp global-env))
(apply-cont k1 exp)))
((list-cont (? env) (? r) (? acc) (? k1))
(eval-list env r (append acc (list exp)) k1))
((application-cont (? env) (? k1))
(apply env exp k1))
((if-cont (? env) (? then-branch) (? else-branch) (? k1))
(if exp
(evald env then-branch k1)
(evald env else-branch k1)))))
(defun evald (env exp k)
(if (is-operator exp)
(apply-cont k exp)
(if (is-symbol exp)
(let ((res (assoc env exp)))
(if (eq res nil)
(apply-cont k (assoc global-env exp))
(apply-cont k res)))
(if (is-number exp)
(apply-cont k exp)
(match exp
((progn . (? ls)) (eval-progn env ls k))
((define . (? ls)) (eval-define env ls k))
((lambda . (? ls)) (eval-lambda env ls k))
((if . (? ls)) (eval-if env ls k))
((?cons ls) (eval-list env ls nil
(list 'application-cont env k)))
)))))
(define test1 '(define apa 1))
(define test2 '(progn (define apa 1) (define bepa 2) (define cepa 3)))
(define test3 '((lambda (x) (+ x 10)) 1))
(define test4 '(progn (define f (lambda (x) (if (= x 0) 0 (f (- x 1))))) (f 10)))
(define test5 '(progn (define g (lambda (acc x) (if (= x 0) acc (g (+ acc x) (- x 1))))) (g 0 10)))
(define test6 '(progn (define f (lambda (x) (+ x 10)))
(define g (lambda (x) (* x 5)))
(f (g 10))))
(define test7 '(progn (define f (lambda (x) (+ x 10)))
(define g (lambda (x) (* x 5)))
(g (f 10))))

158
lispBM/lispBM/repl/evalstack.lisp Normal file
View File

@ -0,0 +1,158 @@
(define global-env 'nil)
(define stack 'nil)
(defun push (v)
(setvar 'stack (cons v stack)))
(defun pop ()
(let ((r (car stack)))
(progn
(setvar 'stack (cdr stack))
r)))
(defun is-number (e)
(or (eq (type-of e) type-i)
(eq (type-of e) type-u)))
(defun is-symbol (e)
(eq (type-of e) type-symbol))
(defun is-operator (e)
(or (eq e '+)
(eq e '-)
(eq e '=)
(eq e '*)
))
(defun is-closure (e)
(and (eq (type-of e) type-list)
(eq (car e) 'closure)))
(defun add-bindings (env binds)
(match binds
(nil env)
(((? b) . (? rs))
(add-bindings (setassoc env b) rs))))
(defun eval-progn (env args)
(match args
(nil (apply-cont nil))
(((? l) . nil) (eval-stack env l))
(((? l) . (? ls))
(progn
(push (list 'progn-cont env ls))
(eval-stack env l)))))
(defun eval-define (env args)
(let ((key (car args))
(val (car (cdr args))))
(progn
(push (list 'define-cont key))
(eval-stack env val))))
(defun eval-lambda (env args)
(apply-cont (append (cons 'closure args) (list env))))
(defun eval-if (env args)
(let ((cond-exp (car args))
(then-branch (car (cdr args)))
(else-branch (car (cdr (cdr args)))))
(progn
(push (list 'if-cont env then-branch else-branch))
(eval-stack env cond-exp))))
(defun eval-list (env ls acc)
(if (eq ls nil)
(apply-cont acc)
(let (( l (car ls))
( r (cdr ls)))
(progn
(push (list 'list-cont env r acc))
(eval-stack env l)))))
(defun apply-closure (env ls)
(let ((clo (car ls))
(args (cdr ls))
(ps (car (cdr clo)))
(body (car (cdr (cdr clo))))
(env1 (car (cdr (cdr (cdr clo)))))
(arg-env (zip ps args))
(new-env (add-bindings (append env1 env) arg-env)))
(eval-stack new-env body)))
(defun apply (env ls)
(let ((f (car ls)))
(if (is-operator f)
(apply-cont (eval ls))
(if (is-closure f)
(apply-closure env ls)
'error))))
(defun apply-cont (exp)
(let (( k (pop)))
(match k
(done exp)
((progn-cont (? env) (? ls)) (eval-progn env ls))
((define-cont (? key))
(progn
(setvar 'global-env (acons key exp global-env))
(apply-cont exp)))
((list-cont (? env) (? r) (? acc))
(eval-list env r (append acc (list exp))))
((application-cont (? env))
(apply env exp))
((if-cont (? env) (? then-branch) (? else-branch))
(if exp
(eval-stack env then-branch)
(eval-stack env else-branch))))))
(defun evals (env exp)
(progn
(setvar 'stack nil)
(push 'done)
(eval-stack env exp)))
(defun eval-stack (env exp)
(if (is-operator exp)
(apply-cont exp)
(if (is-symbol exp)
(let ((res (assoc env exp)))
(if (eq res nil)
(apply-cont (assoc global-env exp))
(apply-cont res)))
(if (is-number exp)
(apply-cont exp)
(match exp
((progn . (? ls)) (eval-progn env ls))
((define . (? ls)) (eval-define env ls))
((lambda . (? ls)) (eval-lambda env ls))
((if . (? ls)) (eval-if env ls))
((?cons ls) (progn
(push (list 'application-cont env))
(eval-list env ls nil)))
)))))
(define test1 '(define apa 1))
(define test2 '(progn (define apa 1) (define bepa 2) (define cepa 3)))
(define test3 '((lambda (x) (+ x 10)) 1))
(define test4 '(progn (define f (lambda (x) (if (= x 0) 0 (f (- x 1))))) (f 10)))
(define test5 '(progn (define g (lambda (acc x) (if (= x 0) acc (g (+ acc x) (- x 1))))) (g 0 10)))
(define test6 '(progn (define f (lambda (x) (+ x 10)))
(define g (lambda (x) (* x 5)))
(f (g 10))))
(define test7 '(progn (define f (lambda (x) (+ x 10)))
(define g (lambda (x) (* x 5)))
(g (f 10))))

143
lispBM/lispBM/repl/evaluator.lisp Normal file
View File

@ -0,0 +1,143 @@
(define global-env 'nil)
(defun is-number (e)
(or (eq (type-of e) type-i)
(eq (type-of e) type-u)))
(defun is-symbol (e)
(eq (type-of e) type-symbol))
(defun is-operator (e)
(or (eq e '+)
(eq e '-)
(eq e '=)
(eq e '*)
))
(defun is-closure (e)
(and (eq (type-of e) type-list)
(eq (car e) 'closure)))
(defun add-bindings (env binds)
(match binds
(nil env)
(((? b) . (? rs))
(add-bindings (setassoc env b) rs))))
(defun done (e)
e)
(defun eval-progn (env args k)
(match args
(nil (k nil))
(((? l) . nil) (evalk env l k))
(((? l) . (? ls))
(evalk env l
(lambda (x)
(eval-progn env ls k)))))
)
(defun eval-define (env args k)
(let ((key (car args))
(val (car (cdr args))))
(evalk env val
(lambda (x)
(progn
(setvar 'global-env
(acons key x global-env))
(k x))))))
(defun eval-lambda (env args k)
(k (append (cons 'closure args) (list env))))
(defun eval-if (env args k)
(let ((cond-exp (car args))
(then-branch (car (cdr args)))
(else-branch (car (cdr (cdr args)))))
(evalk env cond-exp
(lambda (x) (if x
(evalk env then-branch k)
(evalk env else-branch k))))))
(defun eval-list (env ls acc k)
(if (eq ls nil)
(k acc)
(let (( l (car ls))
( r (cdr ls)))
(evalk env l
(lambda (x)
(eval-list env r (append acc (list x)) k))))))
(defun apply-closure (env ls k)
(let ((clo (car ls))
(args (cdr ls))
(ps (car (cdr clo)))
(body (car (cdr (cdr clo))))
(env1 (car (cdr (cdr (cdr clo)))))
(arg-env (zip ps args))
(new-env (add-bindings (append env1 env) arg-env)))
(evalk new-env body k)))
(defun apply (env ls k)
(let ((f (car ls)))
(if (is-operator f)
(k (eval ls))
(if (is-closure f)
(apply-closure env ls k)
'error))))
(defun evalk (env exp k)
(if (is-operator exp)
(k exp)
(if (is-symbol exp)
(let ((res (assoc env exp)))
(if (eq res nil)
(k (assoc global-env exp))
(k res)))
(if (is-number exp)
(k exp)
(match exp
((progn . (? ls)) (eval-progn env ls k))
((define . (? ls)) (eval-define env ls k))
((lambda . (? ls)) (eval-lambda env ls k))
((if . (? ls)) (eval-if env ls k))
((?cons ls) (eval-list env ls nil
(lambda
(rs)
(apply env rs k))))
)))))
(define test1 '(define apa 1))
(define test2 '(progn (define apa 1) (define bepa 2) (define cepa 3)))
(define test3 '((lambda (x) (+ x 10)) 1))
(define test4 '(progn
(define f (lambda (x)
(if (= x 0)
0
(f (- x 1)))))
(f 10)))
(define test5 '(progn
(define g (lambda (acc x)
(if (= x 0)
acc
(g (+ acc x)
(- x 1)))))
(g 0 10)))
(define test6 '(progn (define f (lambda (x) (+ x 10)))
(define g (lambda (x) (* x 5)))
(f (g 10))))
(define test7 '(progn (define f (lambda (x) (+ x 10)))
(define g (lambda (x) (* x 5)))
(g (f 10))))
(define test8 '((lambda (x) ((lambda (x) (+ x 1)) 7)) 1))
(define test9 '(+ (define apa 1) 2))

68
lispBM/lispBM/repl/repl.c
View File

@ -31,6 +31,8 @@
#include "extensions/string_extensions.h"
#include "extensions/math_extensions.h"
#include "lbm_custom_type.h"
#define EVAL_CPS_STACK_SIZE 256
#define GC_STACK_SIZE 256
#define PRINT_STACK_SIZE 256
@ -143,8 +145,8 @@ void erase() {
fflush(stdout);
}
int inputline(char *buffer, unsigned int size) {
unsigned int n = 0;
int inputline(char *buffer, int size) {
int n = 0;
int c;
for (n = 0; n < size - 1; n++) {
@ -202,10 +204,9 @@ void done_callback(eval_context_t *ctx) {
erase();
char output[1024];
lbm_cid cid = ctx->id;
lbm_value t = ctx->r;
int print_ret = lbm_print_value(output, 1024, t);
lbm_print_value(output, 1024, t);
printf("> %s\n", output);
@ -231,9 +232,10 @@ int error_print(const char *format, ...) {
erase();
va_list args;
va_start (args, format);
vprintf(format, args);
int n = vprintf(format, args);
va_end(args);
new_prompt();
return n;
}
uint32_t timestamp_callback() {
@ -387,6 +389,21 @@ static lbm_value ext_range(lbm_value *args, lbm_uint argn) {
return res;
}
static bool test_destruct(lbm_uint value) {
printf("destroying custom value\n");
free((lbm_uint*)value);
return true;
}
static lbm_value ext_custom(lbm_value *args, lbm_uint argn) {
lbm_uint *mem = (lbm_uint*)malloc(1000*sizeof(lbm_uint));
lbm_value res;
lbm_custom_type_create((lbm_uint)mem, test_destruct, "custom_type", &res);
return res;
}
/* load a file, caller is responsible for freeing the returned string */
@ -457,6 +474,21 @@ void ctx_exists(eval_context_t *ctx, void *arg1, void *arg2) {
}
}
void lookup_local(eval_context_t *ctx, void *arg1, void *arg2) {
char output[1024];
lbm_value res;
if (lbm_env_lookup_b(&res, (lbm_value)arg1, ctx->curr_env)) {
lbm_print_value(output, 1024, res);
printf("CTX %d: %s = %s\n", ctx->id, (char *)arg2, output);
} else {
printf("not found\n");
}
}
void sym_it(const char *str) {
printf("%s\n", str);
@ -470,7 +502,6 @@ lbm_uint word_array[1024];
int main(int argc, char **argv) {
unsigned int len = 1024;
int res = 0;
pthread_t lispbm_thd;
@ -478,7 +509,7 @@ int main(int argc, char **argv) {
pthread_mutex_init(&mut, NULL);
lbm_heap_state_t heap_state;
unsigned int heap_size = 2048;
unsigned int heap_size = 8192;
lbm_cons_t *heap_storage = NULL;
for (int i = 0; i < 1024; i ++) {
@ -548,6 +579,12 @@ int main(int argc, char **argv) {
else
printf("Error adding extension.\n");
res = lbm_add_extension("custom", ext_custom);
if (res)
printf("Extension added.\n");
else
printf("Error adding extension.\n");
/* Start evaluator thread */
if (pthread_create(&lispbm_thd, NULL, eval_thd_wrapper, NULL)) {
@ -676,7 +713,7 @@ int main(int argc, char **argv) {
} else if (strncmp(str, ":heap", 5) == 0) {
int size = atoi(str + 5);
if (size > 0) {
heap_size = size;
heap_size = (unsigned int)size;
free(heap_storage);
heap_storage = (lbm_cons_t*)malloc(sizeof(lbm_cons_t) * heap_size);
@ -793,6 +830,21 @@ int main(int argc, char **argv) {
lbm_step_n_eval((uint32_t)num);
free(str);
} else if (strncmp(str, ":inspect", 8) == 0) {
int i = 8;
if (strlen(str) >= 8) {
while (str[i] == ' ') i++;
}
char *sym = str + i;
lbm_uint sym_id = 0;
if (lbm_get_symbol_by_name(sym, &sym_id)) {
lbm_running_iterator(lookup_local, (void*)lbm_enc_sym(sym_id), (void*)sym);
lbm_blocked_iterator(lookup_local, (void*)lbm_enc_sym(sym_id), (void*)sym);
lbm_done_iterator(lookup_local, (void*)lbm_enc_sym(sym_id), (void*)sym);
} else {
printf("symbol does not exist\n");
}
} else if (strncmp(str, ":undef", 6) == 0) {
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {

36
lispBM/lispBM/sdlrepl/Makefile Normal file
View File

@ -0,0 +1,36 @@
LISPBM := ../
include $(LISPBM)/lispbm.mk
PLATFORM_INCLUDE = -I$(LISPBM)/platform/linux/include
PLATFORM_SRC = $(LISPBM)/platform/linux/src/platform_mutex.c
CCFLAGS = -g -Wall -Wconversion -Wsign-compare -pedantic -std=c11
LIBS = -lSDL2_image -lSDL2 -lm
INCS = -I/usr/include/SDL2
LISPBM_SRC += $(LISPBM_EVAL_CPS_SRC)
LISPBM_SRC += lbm_sdl.c
ifdef HEAP_VIS
CCFLAGS += -DVISUALIZE_HEAP
endif
all: CCFLAGS += -DLBM64
all: repl
install: repl
mkdir -p ~/.local/bin
cp repl ~/.local/bin/lbm
debug: CCFLAGS += -g
debug: repl
repl: repl.c $(LISPBM_SRC) $(LISPBM_DEPS)
gcc $(CCFLAGS) $(LISPBM_SRC) $(PLATFORM_SRC) $(LISPBM_FLAGS) repl.c -o repl $(LISPBM_INC) $(PLATFORM_INCLUDE) -lpthread $(LIBS) $(INCS)
clean:
rm repl

281
lispBM/lispBM/sdlrepl/lbm_sdl.c Normal file
View File

@ -0,0 +1,281 @@
/*
Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#include <SDL2/SDL.h>
#include <SDL2/SDL_image.h>
#include <SDL2/SDL_timer.h>
#include <stdio.h>
#include <unistd.h>
#include <stdbool.h>
#include <lispbm.h>
#include <lbm_custom_type.h>
typedef struct {
uint32_t sdl_id;
char *name;
lbm_uint sym_id;
} sdl_symbol_t;
sdl_symbol_t lbm_sdl_events[] = {
{0 , "sdl-no-event", 0},
{SDL_QUIT, "sdl-quit-event", 0},
{SDL_KEYDOWN, "sdl-key-down-event", 0},
{SDL_KEYUP, "sdl-key-up-event", 0}
};
static int register_sdl_event_symbols(void) {
for (int i = 0; i < (sizeof(lbm_sdl_events) / sizeof(sdl_symbol_t)); i ++) {
if (!lbm_add_symbol(lbm_sdl_events[i].name, &lbm_sdl_events[i].sym_id))
return 0;
}
return 1;
}
static lbm_uint lookup_sdl_event_symbol(uint32_t sdl_event) {
for (int i = 0; i < (sizeof(lbm_sdl_events) / sizeof(sdl_symbol_t)); i ++) {
if (sdl_event == lbm_sdl_events[i].sdl_id) {
return lbm_sdl_events[i].sym_id;
}
}
return lbm_sdl_events[0].sym_id;
}
static lbm_value ext_sdl_init(lbm_value *args, lbm_uint argn) {
// TODO init differently depending on args
lbm_value res = lbm_enc_sym(SYM_NIL);
if ((SDL_Init(SDL_INIT_EVERYTHING) == 0) &&
(IMG_Init(IMG_INIT_PNG | IMG_INIT_JPG))) {
res = lbm_enc_sym(SYM_TRUE);
}
return res;
}
static bool sdl_window_destructor(lbm_uint value) {
SDL_DestroyWindow((SDL_Window*)value);
return true;
}
static lbm_value ext_sdl_create_window(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_NIL);
if (argn == 3) {
char *title = lbm_dec_str(args[0]);
if (title) {
int32_t w = lbm_dec_as_i32(args[1]);
int32_t h = lbm_dec_as_i32(args[2]);
SDL_Window* win = SDL_CreateWindow(title,
SDL_WINDOWPOS_CENTERED,
SDL_WINDOWPOS_CENTERED,
w, h, 0);
if (win && !lbm_custom_type_create((lbm_uint)win, sdl_window_destructor, "SDLWindow", &res)) {
SDL_DestroyWindow(win);
}
}
}
return res;
}
static bool sdl_renderer_destructor(lbm_uint value) {
SDL_DestroyRenderer((SDL_Renderer*)value);
return true;
}
static lbm_value ext_sdl_create_soft_renderer(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_NIL);
if (argn == 1 && lbm_type_of(args[0]) == LBM_TYPE_CUSTOM) {
lbm_uint *m = (lbm_uint *)lbm_dec_custom(args[0]);
SDL_Renderer* rend = SDL_CreateRenderer((SDL_Window *)m[CUSTOM_TYPE_VALUE],
-1,SDL_RENDERER_SOFTWARE);
if (rend && !lbm_custom_type_create((lbm_uint)rend, sdl_renderer_destructor, "SDLRenderer", &res)) {
SDL_DestroyRenderer(rend);
}
}
return res;
}
static lbm_value ext_sdl_renderer_set_color(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_TRUE);
if (argn == 4 && lbm_type_of(args[0]) == LBM_TYPE_CUSTOM) {
lbm_uint *m = (lbm_uint *)lbm_dec_custom(args[0]);
SDL_Renderer *rend = (SDL_Renderer *)m[CUSTOM_TYPE_VALUE];
uint8_t r = lbm_dec_as_char(args[1]);
uint8_t g = lbm_dec_as_char(args[2]);
uint8_t b = lbm_dec_as_char(args[3]);
/* SDL functions are 0 on success */
if (SDL_SetRenderDrawColor(rend, r, g, b, SDL_ALPHA_OPAQUE)) {
res = lbm_enc_sym(SYM_NIL);
}
}
return res;
}
static lbm_value ext_sdl_draw_line(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_TRUE);
if (argn == 5 && lbm_type_of(args[0]) == LBM_TYPE_CUSTOM) {
lbm_uint *m = (lbm_uint *)lbm_dec_custom(args[0]);
SDL_Renderer *rend = (SDL_Renderer*)m[CUSTOM_TYPE_VALUE];
int32_t x1 = lbm_dec_as_i32(args[1]);
int32_t y1 = lbm_dec_as_i32(args[2]);
int32_t x2 = lbm_dec_as_i32(args[3]);
int32_t y2 = lbm_dec_as_i32(args[4]);
if (SDL_RenderDrawLine(rend, x1, y1, x2, y2)) {
res = lbm_enc_sym(SYM_NIL);
}
}
return res;
}
static lbm_value ext_sdl_clear(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_TRUE);
if (argn == 1 && lbm_type_of(args[0]) == LBM_TYPE_CUSTOM) {
lbm_uint *m = (lbm_uint *)lbm_dec_custom(args[0]);
SDL_Renderer *rend = (SDL_Renderer*)m[CUSTOM_TYPE_VALUE];
if (SDL_RenderClear(rend)) {
res = lbm_enc_sym(SYM_NIL);
}
}
return res;
}
static lbm_value ext_sdl_present(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_TRUE);
if (argn == 1 && lbm_type_of(args[0]) == LBM_TYPE_CUSTOM) {
lbm_uint *m = (lbm_uint *)lbm_dec_custom(args[0]);
SDL_Renderer *rend = (SDL_Renderer*)m[CUSTOM_TYPE_VALUE];
SDL_RenderPresent(rend);
}
return res;
}
static lbm_value ext_sdl_poll_event(lbm_value *args, lbm_uint argn) {
SDL_Event event;
if (SDL_PollEvent(&event) == 0)
return lbm_enc_sym(lookup_sdl_event_symbol(0));
return lbm_enc_sym(lookup_sdl_event_symbol(event.type));
}
////////////////////////////////////////////////////////////
// Images and Textures
static bool sdl_texture_destructor(lbm_uint value) {
SDL_DestroyTexture((SDL_Texture*)value);
return true;
}
static lbm_value ext_sdl_load_texture(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_NIL);
if (argn == 2 &&
(lbm_type_of(args[0]) == LBM_TYPE_CUSTOM) &&
(lbm_type_of(args[1]) == LBM_TYPE_ARRAY)) {
lbm_uint *m = (lbm_uint *)lbm_dec_custom(args[0]);
SDL_Renderer *rend = (SDL_Renderer*)m[CUSTOM_TYPE_VALUE];
char *filename = lbm_dec_str(args[1]);
if (rend &&
filename) {
SDL_Texture *texture = IMG_LoadTexture(rend, filename);
if (texture &&
!lbm_custom_type_create((lbm_uint)texture, sdl_texture_destructor, "SDLTexture", &res))
SDL_DestroyRenderer(rend);
}
}
return res;
}
static lbm_value ext_sdl_blit(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_NIL);
if (argn == 6 &&
(lbm_type_of(args[0]) == LBM_TYPE_CUSTOM) &&
(lbm_type_of(args[1]) == LBM_TYPE_CUSTOM) &&
lbm_is_number(args[2]) && lbm_is_number(args[3]) &&
lbm_is_number(args[4]) && lbm_is_number(args[5])) {
int32_t x = lbm_dec_as_i32(args[2]);
int32_t y = lbm_dec_as_i32(args[3]);
int32_t w = lbm_dec_as_i32(args[4]);
int32_t h = lbm_dec_as_i32(args[5]);
lbm_uint *m = (lbm_uint *)lbm_dec_custom(args[0]);
SDL_Renderer *rend = (SDL_Renderer*)m[CUSTOM_TYPE_VALUE];
lbm_uint *t = (lbm_uint *)lbm_dec_custom(args[1]);
SDL_Texture *texture = (SDL_Texture*)t[CUSTOM_TYPE_VALUE];
if (rend && texture) {
SDL_Rect dest = { x, y, w, h };
SDL_RenderCopy(rend, texture, NULL, &dest);
res = lbm_enc_sym(SYM_TRUE);
}
}
return res;
}
////////////////////////////////////////////////////////////
// Active LBM SDL extensions
bool lbm_sdl_init(void) {
bool res = true;
register_sdl_event_symbols();
res = res && lbm_add_extension("sdl-init", ext_sdl_init);
res = res && lbm_add_extension("sdl-create-window",ext_sdl_create_window);
res = res && lbm_add_extension("sdl-create-soft-renderer", ext_sdl_create_soft_renderer);
res = res && lbm_add_extension("sdl-renderer-set-color", ext_sdl_renderer_set_color);
res = res && lbm_add_extension("sdl-draw-line", ext_sdl_draw_line);
res = res && lbm_add_extension("sdl-clear", ext_sdl_clear);
res = res && lbm_add_extension("sdl-present", ext_sdl_present);
res = res && lbm_add_extension("sdl-poll-event", ext_sdl_poll_event);
res = res && lbm_add_extension("sdl-load-texture", ext_sdl_load_texture);
res = res && lbm_add_extension("sdl-blit", ext_sdl_blit);
return res;
}

23
lispBM/lispBM/sdlrepl/lbm_sdl.h Normal file
View File

@ -0,0 +1,23 @@
/*
Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#ifndef LBM_SDL_H_
#define LBM_SDL_H_
extern bool lbm_sdl_init(void);
#endif

859
lispBM/lispBM/sdlrepl/repl.c Normal file
View File

@ -0,0 +1,859 @@
/*
Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#define _POSIX_C_SOURCE 200809L
#include <stdlib.h>
#include <stdio.h>
#include <stdarg.h>
#include <errno.h>
#include <pthread.h>
#include <sys/time.h>
#include <unistd.h>
#include <termios.h>
#include <ctype.h>
#include "lispbm.h"
#include "extensions/array_extensions.h"
#include "extensions/string_extensions.h"
#include "extensions/math_extensions.h"
#include "lbm_custom_type.h"
#include "lbm_sdl.h"
#define EVAL_CPS_STACK_SIZE 256
#define GC_STACK_SIZE 256
#define PRINT_STACK_SIZE 256
#define EXTENSION_STORAGE_SIZE 256
#define VARIABLE_STORAGE_SIZE 256
#define WAIT_TIMEOUT 2500
#define STR_SIZE 1024
lbm_uint gc_stack_storage[GC_STACK_SIZE];
lbm_uint print_stack_storage[PRINT_STACK_SIZE];
extension_fptr extension_storage[EXTENSION_STORAGE_SIZE];
lbm_value variable_storage[VARIABLE_STORAGE_SIZE];
static volatile bool allow_print = true;
struct termios old_termios;
struct termios new_termios;
static lbm_tokenizer_string_state_t string_tok_state;
static lbm_tokenizer_char_stream_t string_tok;
pthread_mutex_t mut;
typedef struct read_s {
lbm_cid cid;
char *str;
struct read_s *next;
struct read_s *prev;
} read_t;
read_t *reading = NULL;
void add_reading( read_t *r ) {
pthread_mutex_lock(&mut);
r->next = reading;
r->prev = NULL;
if (reading) reading->prev = r;
reading = r;
pthread_mutex_unlock(&mut);
}
read_t *get_reading(lbm_cid cid) {
pthread_mutex_lock(&mut);
read_t *res = NULL;
read_t *curr = reading;
while (curr) {
if (curr->cid == cid) {
res = curr;
if (curr->prev) {
curr->prev->next = curr->next;
} else {
reading = curr->next;
}
if (curr->next) {
curr->next->prev = curr->prev;
}
break;
}
curr = curr->next;
}
pthread_mutex_unlock(&mut);
return res;
}
void free_reading(read_t *r) {
free(r->str);
free(r);
}
void setup_terminal(void) {
tcgetattr(0,&old_termios);
new_termios = old_termios;
//new_termios.c_iflag; // INPUT MODES
//new_termios.c_oflag; // OUTPUT MODES
//new_termios.c_cflag; // CONTROL MODES
// LOCAL MODES
new_termios.c_lflag &= (tcflag_t) ~(ICANON | ISIG | ECHO);
new_termios.c_cc[VMIN] = 0;
new_termios.c_cc[VTIME] = 0;
//new_termios.c_cc; // SPECIAL CHARACTERS
// LOCAL MODES
// Turn off:
// - canonical mode
// - Signal generation for certain characters (INTR, QUIT, SUSP, DSUSP)
// VMIN: Minimal number of characters for noncanonical read.
// VTIME: Timeout in deciseconds for noncanonical read.
tcsetattr(0, TCSANOW, &new_termios);
}
void restore_terminal(void) {
tcsetattr(0, TCSANOW, &old_termios);
}
void new_prompt() {
printf("\33[2K\r");
printf("# ");
fflush(stdout);
}
void erase() {
printf("\33[2K\r");
fflush(stdout);
}
int inputline(char *buffer, unsigned int size) {
unsigned int n = 0;
int c;
for (n = 0; n < size - 1; n++) {
c = getchar(); // busy waiting.
if (c < 0) {
n--;
struct timespec s;
struct timespec r;
s.tv_sec = 0;
s.tv_nsec = (long)1000 * 1000;
nanosleep(&s, &r);
continue;
}
switch (c) {
case 27:
break;
case 127: /* fall through to below */
case '\b': /* backspace character received */
if (n > 0)
n--;
buffer[n] = 0;
//putchar(0x8); /* output backspace character */
//putchar(' ');
//putchar(0x8);
n--; /* set up next iteration to deal with preceding char location */
break;
case '\n': /* fall through to \r */
case '\r':
buffer[n] = 0;
return n;
default:
if (isprint(c)) { /* ignore non-printable characters */
//putchar(c);
buffer[n] = (char)c;
} else {
n -= 1;
}
break;
}
}
buffer[size - 1] = 0;
return 0; // Filled up buffer without reading a linebreak
}
void *eval_thd_wrapper(void *v) {
lbm_run_eval();
return NULL;
}
void done_callback(eval_context_t *ctx) {
erase();
char output[1024];
lbm_cid cid = ctx->id;
lbm_value t = ctx->r;
int print_ret = lbm_print_value(output, 1024, t);
printf("> %s\n", output);
fflush(stdout);
new_prompt();
}
void read_done_callback(lbm_cid cid) {
erase();
read_t *r = get_reading(cid);
if (r == NULL) {
// This case happens if the lisp code executes "read"
} else {
free_reading(r);
}
fflush(stdout);
new_prompt();
}
int error_print(const char *format, ...) {
erase();
va_list args;
va_start (args, format);
vprintf(format, args);
va_end(args);
new_prompt();
}
uint32_t timestamp_callback() {
struct timeval tv;
gettimeofday(&tv,NULL);
return (uint32_t)(tv.tv_sec * 1000000 + tv.tv_usec);
}
void sleep_callback(uint32_t us) {
struct timespec s;
struct timespec r;
s.tv_sec = 0;
s.tv_nsec = (long)us * 1000;
nanosleep(&s, &r);
}
bool dyn_load(const char *str, const char **code) {
bool res = false;
if (strlen(str) == 5 && strncmp(str, "defun", 5) == 0) {
*code = "(define defun (macro (name args body) `(define ,name (lambda ,args ,body))))";
res = true;
} else if (strlen(str) == 7 && strncmp(str, "reverse", 7) == 0) {
*code = "(define reverse (lambda (xs)"
"(let ((revacc (lambda (acc xs)"
"(if (eq nil xs) acc"
"(revacc (cons (car xs) acc) (cdr xs))))))"
"(revacc nil xs))))";
res = true;
} else if (strlen(str) == 4 && strncmp(str, "iota", 4) == 0) {
*code = "(define iota (lambda (n)"
"(let ((iacc (lambda (acc i)"
"(if (< i 0) acc"
"(iacc (cons i acc) (- i 1))))))"
"(iacc nil (- n 1)))))";
res = true;
} else if (strlen(str) == 6 && strncmp(str, "length", 6) == 0) {
*code = "(define length (lambda (xs)"
"(let ((len (lambda (l xs)"
"(if (eq xs nil) l"
"(len (+ l 1) (cdr xs))))))"
"(len 0 xs))))";
res = true;
} else if (strlen(str) == 4 && strncmp(str, "take", 4) == 0) {
*code = "(define take (lambda (n xs)"
"(let ((take-tail (lambda (acc n xs)"
"(if (= n 0) acc"
"(take-tail (cons (car xs) acc) (- n 1) (cdr xs))))))"
"(reverse (take-tail nil n xs)))))";
res = true;
} else if (strlen(str) == 4 && strncmp(str, "drop", 4) == 0) {
*code = "(define drop (lambda (n xs)"
"(if (= n 0) xs"
"(if (eq xs nil) nil"
"(drop (- n 1) (cdr xs))))))";
res = true;
} else if (strlen(str) == 3 && strncmp(str, "zip", 3) == 0) {
*code = "(define zip (lambda (xs ys)"
"(if (eq xs nil) nil"
"(if (eq ys nil) nil"
"(cons (cons (car xs) (car ys)) (zip (cdr xs) (cdr ys)))))))";
res = true;
} else if (strlen(str) == 3 && strncmp(str, "map", 3) == 0) {
*code = "(define map (lambda (f xs)"
"(if (eq xs nil) nil"
"(cons (f (car xs)) (map f (cdr xs))))))";
res = true;
} else if (strlen(str) == 6 && strncmp(str, "lookup", 6) == 0) {
*code = "(define lookup (lambda (x xs)"
"(if (eq xs nil) nil"
"(if (eq (car (car xs)) x)"
"(car (cdr (car xs)))"
"(lookup x (cdr xs))))))";
res = true;
} else if (strlen(str) == 5 && strncmp(str, "foldr", 5) == 0) {
*code = "(define foldr (lambda (f i xs)"
"(if (eq xs nil) i"
"(f (car xs) (foldr f i (cdr xs))))))";
res = true;
} else if (strlen(str) == 5 && strncmp(str, "foldl", 5) == 0) {
*code = "(define foldl (lambda (f i xs)"
"(if (eq xs nil) i (foldl f (f i (car xs)) (cdr xs)))))";
res = true;
}
return res;
}
lbm_value ext_block(lbm_value *args, lbm_uint argn) {
printf("blocking CID: %d\n", lbm_get_current_cid());
lbm_block_ctx_from_extension();
return lbm_enc_sym(SYM_TRUE);
}
lbm_value ext_print(lbm_value *args, lbm_uint argn) {
erase();
if (argn < 1) return lbm_enc_sym(SYM_NIL);
if (!allow_print) return lbm_enc_sym(SYM_TRUE);
char output[1024];
for (unsigned int i = 0; i < argn; i ++) {
lbm_value t = args[i];
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(t);
switch (array->elt_type){
case LBM_TYPE_CHAR: {
char *data = (char*)array->data;
printf("%s", data);
break;
}
default:
return lbm_enc_sym(SYM_NIL);
break;
}
} else if (lbm_type_of(t) == LBM_TYPE_CHAR) {
printf("%c", lbm_dec_char(t));
} else {
lbm_print_value(output, 1024, t);
printf("%s", output);
}
}
printf("\n");
new_prompt();
return lbm_enc_sym(SYM_TRUE);
}
char output[128];
static lbm_value ext_range(lbm_value *args, lbm_uint argn) {
if (argn != 2 || lbm_type_of(args[0]) != LBM_TYPE_I || lbm_type_of(args[1]) != LBM_TYPE_I) {
return lbm_enc_sym(SYM_EERROR);
}
lbm_int start = lbm_dec_i(args[0]);
lbm_int end = lbm_dec_i(args[1]);
if (start > end || (end - start) > 100) {
return lbm_enc_sym(SYM_EERROR);
}
lbm_value res = lbm_enc_sym(SYM_NIL);
for (lbm_int i = end;i >= start;i--) {
res = lbm_cons(lbm_enc_i(i), res);
}
return res;
}
static bool test_destruct(lbm_uint value) {
printf("destroying custom value\n");
free((lbm_uint*)value);
}
static lbm_value ext_custom(lbm_value *args, lbm_uint argn) {
lbm_uint *mem = (lbm_uint*)malloc(1000*sizeof(lbm_uint));
lbm_value res;
lbm_custom_type_create((lbm_uint)mem, test_destruct, "custom_type", &res);
return res;
}
/* load a file, caller is responsible for freeing the returned string */
char * load_file(char *filename) {
char *file_str = NULL;
//size_t str_len = strlen(filename);
//filename[str_len-1] = 0;
int i = 0;
while (filename[i] == ' ' && filename[i] != 0) {
i ++;
}
FILE *fp;
printf("filename: %s\n", &filename[i]);
if (strlen(&filename[i]) > 0) {
errno = 0;
fp = fopen(&filename[i], "r");
if (!fp) {
return NULL;
}
long fsize_long;
unsigned int fsize;
fseek(fp, 0, SEEK_END);
fsize_long = ftell(fp);
if (fsize_long <= 0) {
return NULL;
}
fsize = (unsigned int) fsize_long;
fseek(fp, 0, SEEK_SET);
file_str = malloc(fsize+1);
memset(file_str, 0 , fsize+1);
if (fread(file_str,1,fsize,fp) != fsize) {
free(file_str);
file_str = NULL;
}
fclose(fp);
}
return file_str;
}
void print_ctx_info(eval_context_t *ctx, void *arg1, void *arg2) {
(void) arg1;
(void) arg2;
char output[1024];
int print_ret = lbm_print_value(output, 1024, ctx->r);
printf("--------------------------------\n");
printf("ContextID: %"PRI_UINT"\n", ctx->id);
printf("Stack SP: %"PRI_UINT"\n", ctx->K.sp);
printf("Stack SP max: %"PRI_UINT"\n", ctx->K.max_sp);
if (print_ret) {
printf("Value: %s\n", output);
} else {
printf("Error: %s\n", output);
}
}
void ctx_exists(eval_context_t *ctx, void *arg1, void *arg2) {
lbm_cid id = *(lbm_cid*)arg1;
bool *exists = (bool*)arg2;
if (ctx->id == id) {
*exists = true;
}
}
void sym_it(const char *str) {
printf("%s\n", str);
}
static lbm_uint memory[LBM_MEMORY_SIZE_8K];
static lbm_uint bitmap[LBM_MEMORY_BITMAP_SIZE_8K];
char char_array[1024];
lbm_uint word_array[1024];
int main(int argc, char **argv) {
unsigned int len = 1024;
int res = 0;
pthread_t lispbm_thd;
pthread_mutex_init(&mut, NULL);
lbm_heap_state_t heap_state;
unsigned int heap_size = 8192;
lbm_cons_t *heap_storage = NULL;
for (int i = 0; i < 1024; i ++) {
char_array[i] = (char)i;
word_array[i] = (lbm_uint)i;
}
//setup_terminal();
heap_storage = (lbm_cons_t*)malloc(sizeof(lbm_cons_t) * heap_size);
if (heap_storage == NULL) {
return 0;
}
if (!lbm_init(heap_storage, heap_size,
gc_stack_storage, GC_STACK_SIZE,
memory, LBM_MEMORY_SIZE_8K,
bitmap, LBM_MEMORY_BITMAP_SIZE_8K,
print_stack_storage, PRINT_STACK_SIZE,
extension_storage, EXTENSION_STORAGE_SIZE)) {
printf("Failed to initialize LispBM\n");
return 0;
}
lbm_set_ctx_done_callback(done_callback);
lbm_set_timestamp_us_callback(timestamp_callback);
lbm_set_usleep_callback(sleep_callback);
lbm_set_dynamic_load_callback(dyn_load);
lbm_set_printf_callback(error_print);
lbm_set_reader_done_callback(read_done_callback);
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
if (lbm_array_extensions_init()) {
printf("Array extensions loaded\n");
} else {
printf("Loading array extensions failed\n");
}
if (lbm_string_extensions_init()) {
printf("String extensions loaded\n");
} else {
printf("Loading string extensions failed\n");
}
if (lbm_math_extensions_init()) {
printf("Math extensions loaded\n");
} else {
printf("Loading math extensions failed\n");
}
res = lbm_add_extension("block", ext_block);
if (res)
printf("Extension added.\n");
else
printf("Error adding extension.\n");
res = lbm_add_extension("print", ext_print);
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");
else
printf("Error adding extension.\n");
res = lbm_add_extension("custom", ext_custom);
if (res)
printf("Extension added.\n");
else
printf("Error adding extension.\n");
res = lbm_sdl_init();
if (res)
printf("SDL extensions added.\n");
else
printf("Error adding SDL extensions.\n");
/* Start evaluator thread */
if (pthread_create(&lispbm_thd, NULL, eval_thd_wrapper, NULL)) {
printf("Error creating evaluation thread\n");
return 1;
}
printf("Lisp REPL started!\n");
printf("Type :quit to exit.\n");
printf(" :info for statistics.\n");
printf(" :load [filename] to load lisp source.\n");
char output[1024];
while (1) {
fflush(stdin);
new_prompt();
char *str = malloc(STR_SIZE);
memset(str, 0 ,STR_SIZE);
ssize_t n = inputline(str,STR_SIZE);
if (n >= 5 && strncmp(str, ":info", 5) == 0) {
printf("--(LISP HEAP)-----------------------------------------------\n");
lbm_get_heap_state(&heap_state);
printf("Heap size: %u Bytes\n", heap_size * 8);
printf("Used cons cells: %"PRI_INT"\n", heap_size - lbm_heap_num_free());
printf("Free cons cells: %"PRI_INT"\n", lbm_heap_num_free());
printf("GC counter: %"PRI_INT"\n", heap_state.gc_num);
printf("Recovered: %"PRI_INT"\n", heap_state.gc_recovered);
printf("Recovered arrays: %"PRI_UINT"\n", heap_state.gc_recovered_arrays);
printf("Marked: %"PRI_INT"\n", heap_state.gc_marked);
printf("--(Symbol and Array memory)---------------------------------\n");
printf("Memory size: %"PRI_UINT" Words\n", lbm_memory_num_words());
printf("Memory free: %"PRI_UINT" Words\n", lbm_memory_num_free());
printf("Allocated arrays: %"PRI_UINT"\n", heap_state.num_alloc_arrays);
printf("Symbol table size: %"PRI_UINT" Bytes\n", lbm_get_symbol_table_size());
printf("Symbol names size: %"PRI_UINT" Bytes\n", lbm_get_symbol_table_size_names());
free(str);
} else if (strncmp(str, ":env", 4) == 0) {
lbm_value curr = *lbm_get_env_ptr();
printf("Environment:\r\n");
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
res = lbm_print_value(output,1024, lbm_car(curr));
curr = lbm_cdr(curr);
printf(" %s\r\n",output);
}
printf("Variables:\r\n");
for (int i = 0; i < lbm_get_num_variables(); i ++) {
const char *name = lbm_get_variable_name_by_index(i);
lbm_print_value(output,1024, lbm_get_variable_by_index(i));
printf(" %s = %s\r\n", name ? name : "error", output);
}
free(str);
}else if (n >= 5 && strncmp(str, ":load", 5) == 0) {
read_t *r = malloc(sizeof(read_t));
char *file_str = load_file(&str[5]);
if (file_str) {
lbm_create_char_stream_from_string(&string_tok_state,
&string_tok,
file_str);
/* Get exclusive access to the heap */
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
lbm_cid cid = lbm_load_and_eval_program(&string_tok);
r->str = file_str;
r->cid = cid;
add_reading(r);
lbm_continue_eval();
//printf("started ctx: %"PRI_UINT"\n", cid);
}
free(str);
} else if (n >= 5 && strncmp(str, ":verb", 5) == 0) {
lbm_toggle_verbose();
free(str);
continue;
} else if (n >= 4 && strncmp(str, ":pon", 4) == 0) {
allow_print = true;
free(str);
continue;
} else if (n >= 5 && strncmp(str, ":poff", 5) == 0) {
allow_print = false;
free(str);
continue;
} else if (strncmp(str, ":ctxs", 5) == 0) {
printf("****** Running contexts ******\n");
lbm_running_iterator(print_ctx_info, NULL, NULL);
printf("****** Blocked contexts ******\n");
lbm_blocked_iterator(print_ctx_info, NULL, NULL);
printf("****** Done contexts ******\n");
lbm_done_iterator(print_ctx_info, NULL, NULL);
free(str);
} else if (strncmp(str, ":unblock", 8) == 0) {
int id = atoi(str + 8);
printf("Unblocking: %d\n", id);
lbm_unblock_ctx(id, lbm_enc_i(42));
free(str);
} else if (strncmp(str, ":wait", 5) == 0) {
int id = atoi(str + 5);
bool exists = false;
lbm_done_iterator(ctx_exists, (void*)&id, (void*)&exists);
if (exists) {
if (!lbm_wait_ctx((lbm_cid)id, WAIT_TIMEOUT)) {
printf("Timout while waiting for context %d\n", id);
}
}
free(str);
} else if (n >= 5 && strncmp(str, ":quit", 5) == 0) {
free(str);
break;
} else if (strncmp(str, ":symbols", 8) == 0) {
lbm_symrepr_name_iterator(sym_it);
free(str);
} else if (strncmp(str, ":heap", 5) == 0) {
int size = atoi(str + 5);
if (size > 0) {
heap_size = size;
free(heap_storage);
heap_storage = (lbm_cons_t*)malloc(sizeof(lbm_cons_t) * heap_size);
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
lbm_init(heap_storage, heap_size,
gc_stack_storage, GC_STACK_SIZE,
memory, LBM_MEMORY_SIZE_8K,
bitmap, LBM_MEMORY_BITMAP_SIZE_8K,
print_stack_storage, PRINT_STACK_SIZE,
extension_storage, EXTENSION_STORAGE_SIZE);
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
if (lbm_array_extensions_init()) {
printf("Array extensions loaded\n");
} else {
printf("Loading array extensions failed\n");
}
if (lbm_string_extensions_init()) {
printf("String extensions loaded\n");
} else {
printf("Loading string extensions failed\n");
}
if (lbm_math_extensions_init()) {
printf("Math extensions loaded\n");
} else {
printf("Loading math extensions failed\n");
}
res = lbm_add_extension("block", ext_block);
if (res)
printf("Extension added.\n");
else
printf("Error adding extension.\n");
lbm_add_extension("print", ext_print);
free(str);
}
} else if (strncmp(str, ":reset", 6) == 0) {
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
lbm_init(heap_storage, heap_size,
gc_stack_storage, GC_STACK_SIZE,
memory, LBM_MEMORY_SIZE_8K,
bitmap, LBM_MEMORY_BITMAP_SIZE_8K,
print_stack_storage, PRINT_STACK_SIZE,
extension_storage, EXTENSION_STORAGE_SIZE);
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
if (lbm_array_extensions_init()) {
printf("Array extensions loaded\n");
} else {
printf("Loading array extensions failed\n");
}
if (lbm_string_extensions_init()) {
printf("String extensions loaded\n");
} else {
printf("Loading string extensions failed\n");
}
if (lbm_math_extensions_init()) {
printf("Math extensions loaded\n");
} else {
printf("Loading math extensions failed\n");
}
lbm_add_extension("print", ext_print);
free(str);
} else if (strncmp(str, ":send", 5) == 0) {
int id;
int i_val;
if (sscanf(str + 5, "%d%d", &id, &i_val) == 2) {
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
if (lbm_send_message((lbm_cid)id, lbm_enc_i(i_val)) == 0) {
printf("Could not send message\n");
}
lbm_continue_eval();
} else {
printf("Incorrect arguments to send\n");
}
free(str);
} else if (strncmp(str, ":pause", 6) == 0) {
lbm_pause_eval_with_gc(30);
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
printf("Evaluator paused\n");
free(str);
} else if (strncmp(str, ":continue", 9) == 0) {
lbm_continue_eval();
free(str);
} else if (strncmp(str, ":step", 5) == 0) {
int num = atoi(str + 5);
lbm_step_n_eval((uint32_t)num);
free(str);
} else if (strncmp(str, ":undef", 6) == 0) {
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
char *sym = str + 7;
printf("undefining: %s\n", sym);
printf("%s\n", lbm_undefine(sym) ? "Cleared bindings" : "No definition found");
lbm_continue_eval();
free(str);
} else {
/* Get exclusive access to the heap */
read_t *r = malloc(sizeof(read_t));
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
//printf("loading: %s\n", str);
lbm_create_char_stream_from_string(&string_tok_state,
&string_tok,
str);
lbm_cid cid = lbm_load_and_eval_expression(&string_tok);
r->str = str;
r->cid = cid;
add_reading(r);
lbm_continue_eval();
//printf("started ctx: %"PRI_UINT"\n", cid);
}
}
free(heap_storage);
//restore_terminal();
return 0;
}

4
lispBM/lispBM/sdlrepl/runinfer.sh Executable file
View File

@ -0,0 +1,4 @@
#!/bin/sh
make clean
infer run -- make all64

4
lispBM/lispBM/sdlrepl/runsa.sh Executable file
View File

@ -0,0 +1,4 @@
#!/bin/sh
make clean
scan-build-10 -o ./static_analysis make -j4

66
lispBM/lispBM/sdlrepl/sdl.lisp Normal file
View File

@ -0,0 +1,66 @@
(sdl-init)
(define w 500)
(define h 500)
(defun degtorad (d)
(/ (* d 3.141) 180.0))
(defun rotate (p angle)
`(,(- (* (car p) (cos (degtorad angle)))
(* (cdr p) (sin (degtorad angle))))
.
,(+ (* (car p) (sin (degtorad angle)))
(* (cdr p) (cos (degtorad angle))))))
(defun trans (p v)
`(,(+ (car p) (car v)) . ,(+ (cdr p) (cdr v))))
(defun move (p ang s)
(let ((v (rotate `( 0 . ,(- s)) ang)))
(trans p v)))
(defun event-loop (w)
(let ((event (sdl-poll-event)))
(if (eq event 'sdl-quit-event)
(custom-destruct w)
(progn
(yield 5000)
(event-loop w)))))
(defun line (rend p1 p2)
(sdl-draw-line rend (car p1) (cdr p1) (car p2) (cdr p2)))
(defun draw-figure (rend p ang s)
(if (<= s 1)
()
(let ((p1 (move p ang s)))
(progn
(line rend p p1)
(draw-figure rend p1 (+ ang 2) (- s 1))
(draw-figure rend p1 (- ang 27) (/ s 2))
(draw-figure rend p1 (+ ang 27) (/ s 2))))))
(defun main ()
(let ((win (sdl-create-window "LISP-GFX" 500 500))
(rend (sdl-create-soft-renderer win)))
(progn
(spawn 100 event-loop win)
(sdl-renderer-set-color rend 0 0 0)
(sdl-clear rend)
(sdl-renderer-set-color rend 255 255 255)
(draw-figure rend '(250 . 400) 0 25)
(sdl-present rend)
(custom-destruct rend)
'done
)))
(defun clean ()
(gc))

48
lispBM/lispBM/sdlrepl/sdl_texture.lisp Normal file
View File

@ -0,0 +1,48 @@
(sdl-init)
(define w 500)
(define h 500)
(defun event-loop (w)
(let ((event (sdl-poll-event)))
(if (eq event 'sdl-quit-event)
(custom-destruct w)
(progn
(yield 5000)
(event-loop w)))))
(defun draw-loop (rend tex x y dx dy)
(let ((cx (and (< dx 0) (<= x 0)))
(cy (and (< dy 0) (<= y 0)))
(cx-high (and (> dx 0) (>= x 420)))
(cy-high (and (> dy 0) (>= y 420)))
(dx-new (if (or cx cx-high) (* -1 dx) dx))
(dy-new (if (or cy cy-high) (* -1 dy) dy)))
(progn
(sdl-clear rend)
(sdl-blit rend tex x y 80 80)
(sdl-present rend)
(yield 8000)
(draw-loop rend tex (+ x dx-new) (+ y dy-new) dx-new dy-new)
)
)
)
(defun main ()
(let ((win (sdl-create-window "LISP-GFX" 500 500))
(rend (sdl-create-soft-renderer win))
(tex (sdl-load-texture rend "tex1.png")))
(progn
(spawn 100 event-loop win)
(sdl-renderer-set-color rend 0 0 0)
(sdl-clear rend)
(draw-loop rend tex 17 250 -1 3)
)))
(defun clean ()
(gc))

BIN
lispBM/lispBM/sdlrepl/tex1.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 323 KiB

95
lispBM/lispBM/src/eval_cps.c
View File

@ -1111,7 +1111,7 @@ static inline void dynamic_load(eval_context_t *ctx) {
lbm_set_car(cell, (lbm_uint)array);
lbm_set_cdr(cell, lbm_enc_sym(SYM_ARRAY_TYPE));
cell = cell | LBM_TYPE_ARRAY;
cell = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY);
lbm_value stream = token_stream_from_string_value(cell);
if (lbm_type_of(stream) == LBM_TYPE_SYMBOL) {
@ -1134,30 +1134,19 @@ static inline void dynamic_load(eval_context_t *ctx) {
}
}
static inline void eval_selfevaluating(eval_context_t *ctx) {
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
}
static inline void eval_quote(eval_context_t *ctx) {
ctx->r = lbm_cadr(ctx->curr_exp);
ctx->app_cont = true;
}
static inline void eval_macro(eval_context_t *ctx) {
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
}
static inline void eval_closure(eval_context_t *ctx) {
static inline void eval_selfevaluating(eval_context_t *ctx) {
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
}
static inline void eval_callcc(eval_context_t *ctx) {
//lbm_value continuation = NIL;
lbm_value cont_array;
#ifndef LBM64
if (!lbm_heap_allocate_array(&cont_array, ctx->K.sp, LBM_TYPE_U32)) {
@ -1170,7 +1159,7 @@ static inline void eval_callcc(eval_context_t *ctx) {
#else
if (!lbm_heap_allocate_array(&cont_array, ctx->K.sp, LBM_TYPE_U64)) {
gc(NIL,NIL);
if (!lbm_heap_allocate_array(&cont_array, ctx->K.sp, LBM_TYPE_U32)) {
if (!lbm_heap_allocate_array(&cont_array, ctx->K.sp, LBM_TYPE_U64)) {
error_ctx(lbm_enc_sym(SYM_MERROR));
return;
}
@ -1189,16 +1178,10 @@ static inline void eval_callcc(eval_context_t *ctx) {
CONS_WITH_GC(app, acont, app, acont);
CONS_WITH_GC(app, fun_arg, app, app);
//ctx->r = NIL;
ctx->curr_exp = app;
ctx->app_cont = false;
}
static inline void eval_continuation(eval_context_t *ctx) {
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
}
static inline void eval_define(eval_context_t *ctx) {
lbm_value args = lbm_cdr(ctx->curr_exp);
lbm_value key = lbm_car(args);
@ -1231,7 +1214,6 @@ static inline void eval_define(eval_context_t *ctx) {
return;
}
static inline void eval_progn(eval_context_t *ctx) {
lbm_value exps = lbm_cdr(ctx->curr_exp);
lbm_value env = ctx->curr_env;
@ -1247,6 +1229,8 @@ static inline void eval_progn(eval_context_t *ctx) {
sptr[2] = PROGN_REST;
ctx->curr_exp = lbm_car(exps);
ctx->curr_env = env;
if (lbm_is_symbol(sptr[1])) /* The only symbol it can be is nil */
lbm_stack_drop(&ctx->K, 3);
} else if (lbm_is_symbol_nil(exps)) {
ctx->r = NIL;
ctx->app_cont = true;
@ -1255,18 +1239,15 @@ static inline void eval_progn(eval_context_t *ctx) {
}
}
static inline lbm_value mk_closure(lbm_value env, lbm_value body, lbm_value params) {
lbm_value env_end = cons_with_gc( env, NIL, env);
lbm_value exp = cons_with_gc(body, env_end, env_end);
lbm_value par = cons_with_gc(params, exp, exp);
return cons_with_gc(lbm_enc_sym(SYM_CLOSURE), par, par);
}
static inline void eval_lambda(eval_context_t *ctx) {
lbm_value env_cpy = ctx->curr_env;
lbm_value env_end;
lbm_value body;
lbm_value params;
lbm_value closure;
CONS_WITH_GC(env_end, env_cpy, NIL, env_cpy);
CONS_WITH_GC(body, lbm_cadr(lbm_cdr(ctx->curr_exp)), env_end, env_end);
CONS_WITH_GC(params, lbm_cadr(ctx->curr_exp), body, body);
CONS_WITH_GC(closure, lbm_enc_sym(SYM_CLOSURE), params, params);
lbm_value closure = mk_closure(ctx->curr_env, lbm_cadr(lbm_cdr(ctx->curr_exp)), lbm_cadr(ctx->curr_exp));
ctx->app_cont = true;
ctx->r = closure;
return;
@ -1865,8 +1846,13 @@ static inline void cont_closure_application_args(eval_context_t *ctx) {
lbm_set_error_reason("Too many arguments.");
error_ctx(lbm_enc_sym(SYM_EERROR));
} else if (a_nil && !p_nil) {
lbm_set_error_reason("Too few arguments.");
error_ctx(lbm_enc_sym(SYM_EERROR));
lbm_value new_env = lbm_list_append(arg_env,clo_env);
lbm_value closure = mk_closure(new_env, exp, lbm_cdr(params));
lbm_stack_drop(&ctx->K, 5);
ctx->app_cont = true;
ctx->r = closure;
//lbm_set_error_reason("Too few arguments.");
//error_ctx(lbm_enc_sym(SYM_EERROR));
} else {
sptr[2] = clo_env;
sptr[3] = lbm_cdr(params);
@ -1939,11 +1925,25 @@ static inline void cont_or(eval_context_t *ctx) {
}
static inline void cont_bind_to_key_rest(eval_context_t *ctx) {
lbm_value key;
lbm_value env;
lbm_value rest;
lbm_value arg = ctx->r;
lbm_pop_3(&ctx->K, &key, &env, &rest);
lbm_value *sptr = lbm_get_stack_ptr(&ctx->K, 4);
if (!sptr) {
error_ctx(lbm_enc_sym(SYM_FATAL_ERROR));
return;
}
lbm_value rest = sptr[1];
lbm_value env = sptr[2];
lbm_value key = sptr[3];
lbm_type keyt = lbm_type_of(key);
if ((keyt != LBM_TYPE_SYMBOL) ||
((keyt == LBM_TYPE_SYMBOL) && lbm_dec_sym(key) < RUNTIME_SYMBOLS_START)) {
lbm_set_error_reason("Incorrect type of name/key in let-binding");
error_ctx(lbm_enc_sym(SYM_EERROR));
return;
}
lbm_env_modify_binding(env, key, arg);
@ -1951,16 +1951,16 @@ static inline void cont_bind_to_key_rest(eval_context_t *ctx) {
lbm_value keyn = lbm_car(lbm_car(rest));
lbm_value valn_exp = lbm_cadr(lbm_car(rest));
CHECK_STACK(lbm_push_4(&ctx->K, lbm_cdr(rest), env, keyn, BIND_TO_KEY_REST));
sptr[1] = lbm_cdr(rest);
sptr[3] = keyn;
CHECK_STACK(lbm_push(&ctx->K, BIND_TO_KEY_REST));
ctx->curr_exp = valn_exp;
ctx->curr_env = env;
} else {
// Otherwise evaluate the expression in the populated env
lbm_value exp;
lbm_pop(&ctx->K, &exp);
ctx->curr_exp = exp;
ctx->curr_exp = sptr[0];
ctx->curr_env = env;
lbm_stack_drop(&ctx->K, 4);
}
}
@ -2450,7 +2450,6 @@ static void evaluation_step(void){
case SET_GLOBAL_ENV: cont_set_global_env(ctx); return;
case PROGN_REST: cont_progn_rest(ctx); return;
case WAIT: cont_wait(ctx); return;
// case APPLICATION: cont_application(ctx); return;
case APPLICATION_ARGS: cont_application_args(ctx); return;
case AND: cont_and(ctx); return;
case OR: cont_or(ctx); return;
@ -2519,17 +2518,17 @@ static void evaluation_step(void){
case SYM_DEFINE: eval_define(ctx); return;
case SYM_PROGN: eval_progn(ctx); return;
case SYM_LAMBDA: eval_lambda(ctx); return;
case SYM_CLOSURE: eval_closure(ctx); return;
case SYM_IF: eval_if(ctx); return;
case SYM_LET: eval_let(ctx); return;
case SYM_AND: eval_and(ctx); return;
case SYM_OR: eval_or(ctx); return;
case SYM_MATCH: eval_match(ctx); return;
/* message passing primitives */
case SYM_RECEIVE: eval_receive(ctx); return;
case SYM_MACRO: eval_macro(ctx); return;
case SYM_CALLCC: eval_callcc(ctx); return;
case SYM_CONT: eval_continuation(ctx); return;
case SYM_MACRO: /* fall through */
case SYM_CONT:
case SYM_CLOSURE: eval_selfevaluating(ctx); return;
default: break; /* May be general application form. Checked below*/
}

54
lispBM/lispBM/src/fundamental.c
View File

@ -25,6 +25,7 @@
#include "lbm_variables.h"
#include "env.h"
#include "lbm_utils.h"
#include "lbm_custom_type.h"
#include <stdio.h>
#include <math.h>
@ -639,7 +640,6 @@ lbm_value index_list(lbm_value l, unsigned int n) {
lbm_value assoc_lookup(lbm_value key, lbm_value assoc) {
lbm_value curr = assoc;
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
lbm_value c = lbm_ref_cell(curr)->car;
if (struct_eq(lbm_ref_cell(c)->car, key)) {
@ -647,7 +647,7 @@ lbm_value assoc_lookup(lbm_value key, lbm_value assoc) {
}
curr = lbm_ref_cell(curr)->cdr;
}
return lbm_enc_sym(SYM_NOT_FOUND);
return lbm_enc_sym(SYM_NO_MATCH);
}
lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
@ -866,15 +866,19 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
}
}break;
case SYM_ASSOC: {
if (nargs == 2 && lbm_is_list(args[0])) {
lbm_value r = assoc_lookup(args[1], args[0]);
if (lbm_is_symbol(r) &&
lbm_dec_sym(r) == SYM_NOT_FOUND) {
result = lbm_enc_sym(SYM_NIL);
}
else {
result = r;
}
if (nargs == 2) {
if (lbm_is_list(args[0])) {
lbm_value r = assoc_lookup(args[1], args[0]);
if (lbm_is_symbol(r) &&
lbm_dec_sym(r) == SYM_NO_MATCH) {
result = lbm_enc_sym(SYM_NIL);
} else {
result = r;
}
} else if (lbm_is_symbol(args[0]) &&
lbm_dec_sym(args[0]) == SYM_NIL) {
result = args[0]; /* nil */
} /* else error */
}
} break;
case SYM_ACONS: {
@ -907,11 +911,25 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
break;
}
case SYM_CAR: {
result = lbm_car(args[0]);
if (nargs == 1) {
if (lbm_type_of(args[0]) == LBM_TYPE_CONS) {
lbm_cons_t *cell = lbm_ref_cell(args[0]);
result = cell->car;
} else {
result = lbm_enc_sym(SYM_NIL);
}
}
break;
}
case SYM_CDR: {
result = lbm_cdr(args[0]);
if (nargs == 1) {
if (lbm_type_of(args[0]) == LBM_TYPE_CONS) {
lbm_cons_t *cell = lbm_ref_cell(args[0]);
result = cell->cdr;
} else {
result = lbm_enc_sym(SYM_NIL);
}
}
break;
}
case SYM_LIST: {
@ -1236,6 +1254,16 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
result = bitwise_not(args[0]);
}
break;
case SYM_CUSTOM_DESTRUCT:
if (nargs == 1 && (lbm_type_of(args[0]) == LBM_TYPE_CUSTOM)) {
lbm_uint *mem_ptr = (lbm_uint*)lbm_dec_custom(args[0]);
lbm_custom_type_destroy(mem_ptr);
lbm_value tmp = lbm_set_ptr_type(args[0], LBM_TYPE_CONS);
lbm_set_car(tmp, lbm_enc_sym(SYM_NIL));
lbm_set_cdr(tmp, lbm_enc_sym(SYM_NIL));
/* The original value will still be of type custom_ptr */
result = lbm_enc_sym(SYM_TRUE);
} break;
default:
result = lbm_enc_sym(SYM_EERROR);
break;

16
lispBM/lispBM/src/heap.c
View File

@ -21,6 +21,7 @@
#include <stdint.h>
#include <inttypes.h>
#include <lbm_memory.h>
#include <lbm_custom_type.h>
#include "heap.h"
#include "symrepr.h"
@ -56,6 +57,14 @@ lbm_stream_t *lbm_dec_stream(lbm_value val) {
return res;
}
lbm_uint lbm_dec_custom(lbm_value val) {
lbm_uint res = 0;
if (lbm_type_of(val) == LBM_TYPE_CUSTOM) {
res = (lbm_uint)lbm_car(val);
}
return res;
}
char lbm_dec_as_char(lbm_value a) {
switch (lbm_type_of(a)) {
case LBM_TYPE_CHAR:
@ -511,6 +520,11 @@ int lbm_gc_sweep_phase(void) {
lbm_memory_free((lbm_uint*)stream);
}
} break;
case SYM_CUSTOM_TYPE: {
lbm_uint *t = (lbm_uint*)heap[i].car;
lbm_custom_type_destroy(t);
lbm_memory_free(t);
} break;
default:
break;
}
@ -763,7 +777,7 @@ int lbm_heap_allocate_array(lbm_value *res, lbm_uint size, lbm_type type){
lbm_set_car(cell, (lbm_uint)array);
lbm_set_cdr(cell, lbm_enc_sym(SYM_ARRAY_TYPE));
cell = cell | LBM_TYPE_ARRAY;
cell = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY);
*res = cell;

2
lispBM/lispBM/src/lbm_c_interop.c
View File

@ -230,7 +230,7 @@ int lbm_share_array(lbm_value *value, char *data, lbm_type type, lbm_uint num_el
lbm_set_car(cell, (lbm_uint)array);
lbm_set_cdr(cell, lbm_enc_sym(SYM_ARRAY_TYPE));
cell = cell | LBM_TYPE_ARRAY;
cell = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY);
*value = cell;
return 1;
}

56
lispBM/lispBM/src/lbm_custom_type.c Normal file
View File

@ -0,0 +1,56 @@
/*
Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#include <lbm_custom_type.h>
#include <heap.h>
#include <lbm_memory.h>
bool lbm_custom_type_create(lbm_uint value, custom_type_destructor fptr, const char *desc, lbm_value *result) {
lbm_uint *t = lbm_memory_allocate(3);
if (t == NULL) return false;
t[CUSTOM_TYPE_VALUE] = value;
t[CUSTOM_TYPE_DESCRIPTOR] = (lbm_uint)desc;
t[CUSTOM_TYPE_DESTRUCTOR] = (lbm_uint)fptr;
lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CONS);
if (lbm_type_of(cell) == LBM_TYPE_SYMBOL) {
*result = cell;
lbm_memory_free(t);
return false;
}
lbm_set_car(cell, (lbm_uint)t);
lbm_set_cdr(cell, lbm_enc_sym(SYM_CUSTOM_TYPE));
cell = lbm_set_ptr_type(cell, LBM_TYPE_CUSTOM);
*result = cell;
return true;
}
bool lbm_custom_type_destroy(lbm_uint *lbm_mem_ptr) {
lbm_uint value = lbm_mem_ptr[CUSTOM_TYPE_VALUE];
custom_type_destructor destruct = (custom_type_destructor)lbm_mem_ptr[CUSTOM_TYPE_DESTRUCTOR];
destruct(value);
if (lbm_memory_free(lbm_mem_ptr))
return true;
return false;
}

2
lispBM/lispBM/src/lbm_memory.c
View File

@ -307,7 +307,7 @@ int lbm_memory_free(lbm_uint *ptr) {
return 0;
}
int lbm_memory_shrink(lbm_uint *ptr, unsigned int n) {
int lbm_memory_shrink(lbm_uint *ptr, lbm_uint n) {
lbm_uint ix = address_to_bitmap_ix(ptr);
if (status(ix) != START) {

15
lispBM/lispBM/src/print.c
View File

@ -20,6 +20,7 @@
#include <string.h>
#include <inttypes.h>
#include <lbm_types.h>
#include <lbm_custom_type.h>
#include "print.h"
#include "heap.h"
@ -348,8 +349,16 @@ int lbm_print_value(char *buf,unsigned int len, lbm_value t) {
return -1;
}
offset += n;
break;
}
} break;
case LBM_TYPE_CUSTOM: {
lbm_uint *custom = (lbm_uint*)lbm_car(curr);
if (custom[CUSTOM_TYPE_DESCRIPTOR]) {
r = snprintf(buf + offset, len - offset, "%s", (char*)custom[CUSTOM_TYPE_DESCRIPTOR]);
} else {
r = snprintf(buf + offset, len - offset, "Unspecified_Custom_Type");
}
offset += n;
} break;
case LBM_TYPE_SYMBOL:
str_ptr = lbm_get_name_by_symbol(lbm_dec_sym(curr));
if (str_ptr == NULL) {
@ -401,7 +410,7 @@ int lbm_print_value(char *buf,unsigned int len, lbm_value t) {
break;
default:
snprintf(buf, len, "Error: print does not recognize type of value: %"PRI_HEX"", curr);
snprintf(buf, len, "Error: print does not recognize type %"PRI_HEX" of value: %"PRI_HEX"", lbm_type_of(curr), curr);
return -1;
break;
} // Switch type of curr

2
lispBM/lispBM/src/streams.c
View File

@ -41,7 +41,7 @@ lbm_value lbm_stream_put(lbm_stream_t *str, lbm_value v) {
lbm_value lbm_stream_create(lbm_stream_t *str) {
lbm_value s = lbm_cons((lbm_value)str, lbm_enc_sym(SYM_STREAM_TYPE));
if (lbm_type_of(s) == LBM_TYPE_CONS) {
s = s | LBM_TYPE_STREAM;
s = lbm_set_ptr_type(s, LBM_TYPE_STREAM);
}
return s;
}

3
lispBM/lispBM/src/symrepr.c
View File

@ -88,6 +88,7 @@ special_sym const special_symbols[] = {
{"sym_stream" , SYM_STREAM_TYPE},
{"sym_recovered" , SYM_RECOVERED},
{"sym_bytecode" , SYM_BYTECODE_TYPE},
{"sym_custom" , SYM_CUSTOM_TYPE},
{"sym_nonsense" , SYM_NONSENSE},
{"variable_not_bound" , SYM_NOT_FOUND},
@ -166,6 +167,8 @@ special_sym const special_symbols[] = {
{"bitwise-xor" , SYM_BITWISE_XOR},
{"bitwise-not" , SYM_BITWISE_NOT},
{"custom-destruct", SYM_CUSTOM_DESTRUCT},
{"to-i" , SYM_TO_I},
{"to-i32" , SYM_TO_I32},
{"to-u" , SYM_TO_U},

12
lispBM/lispBM/src/tokpar.c
View File

@ -520,8 +520,14 @@ bool parse_array(lbm_tokenizer_char_stream_t *str, lbm_uint initial_size, lbm_va
if (n) arr->data[ix] = (uint32_t)(i_val.negative ? -i_val.value : i_val.value);
break;
case LBM_TYPE_FLOAT: {
float f = 0;
n = tok_D(str, &f_val);
float f = (float)f_val.value;
if (n == 0) {
n = tok_integer(str, &i_val);
f = (float)i_val.value;
} else {
f = (float)f_val.value;
}
if (n) memcpy(&arr->data[ix], (uint32_t*)&f, sizeof(float));
}break;
}
@ -806,7 +812,3 @@ void lbm_create_char_stream_from_string(lbm_tokenizer_string_state_t *state,
char_stream->column = column_string;
}
/* VALUE tokpar_parse(tokenizer_char_stream_t *char_stream) { */
/* return tokpar_parse_program(char_stream); */
/* } */

5
lispBM/lispBM/tests/test_array_syntax_10.lisp Normal file
View File

@ -0,0 +1,5 @@
(define arr [type-float 1 2 3 4 5])
(= (array-read arr 3) 4.0)

4
lispBM/lispBM/tests/test_array_syntax_9.lisp Normal file
View File

@ -0,0 +1,4 @@
(define arr [type-float 1.0 2.0 3.0 4.0 5.0])
(= (array-read arr 3) 4.0)

2
lispBM/lispBM/tests/test_car_0.lisp Normal file
View File

@ -0,0 +1,2 @@
(eq (car 1) nil)

2
lispBM/lispBM/tests/test_car_1.lisp Normal file
View File

@ -0,0 +1,2 @@
(eq (car '(1 . 2)) 1)

2
lispBM/lispBM/tests/test_car_2.lisp Normal file
View File

@ -0,0 +1,2 @@
(eq (car [1 2 3]) nil)

2
lispBM/lispBM/tests/test_cdr_0.lisp Normal file
View File

@ -0,0 +1,2 @@
(eq (cdr 1) nil)

2
lispBM/lispBM/tests/test_cdr_1.lisp Normal file
View File

@ -0,0 +1,2 @@
(eq (cdr '(1 . 2)) 2)

2
lispBM/lispBM/tests/test_cdr_2.lisp Normal file
View File

@ -0,0 +1,2 @@
(eq (cdr [1 2 3 4]) nil)

5
lispBM/lispBM/tests/test_partial_0.lisp Normal file
View File

@ -0,0 +1,5 @@
(define f (lambda (x y z w) (+ x y z w)))
(= ((f 1) 2 3 4) 10)

3
lispBM/lispBM/tests/test_partial_1.lisp Normal file
View File

@ -0,0 +1,3 @@
(define f (lambda (x y z w) (+ x y z w)))
(= (((f 1) 2) 3 4) 10)

3
lispBM/lispBM/tests/test_partial_2.lisp Normal file
View File

@ -0,0 +1,3 @@
(define f (lambda (x y z w) (+ x y z w)))
(= ((((f 1) 2) 3) 4) 10)

5
lispBM/lispBM/tests/test_partial_3.lisp Normal file
View File

@ -0,0 +1,5 @@
(define f (lambda (x y z w) (+ x y z w)))
(define g (f 1 2))
(= (g 3 4) 10)

5
lispBM/lispBM/tests/test_partial_4.lisp Normal file
View File

@ -0,0 +1,5 @@
(define f (lambda (x y z w) (+ x y z w)))
(define g (f 1 2))
(= ((g 3) 4) 10)

4
lispBM/lispBM/tests/test_partial_5.lisp Normal file
View File

@ -0,0 +1,4 @@
(let ((apa 2))
(defun f (x y z w) (+ apa x y z w)))
(= ((f 1) 2 3 4) 12)

2
lispBM/lispBM/tests/test_refmut_7.lisp
View File

@ -1,3 +1,3 @@
(let ((a (cons 1 2)))
(progn (setcar a 10)
(= (and (car a 10) (cdr a 2)))))
(and (= (car a) 10) (= (cdr a) 2))))