mirror of https://github.com/rusefi/bldc.git
Merge commit '85ee6ead0306844c2a05f4b205479d0be4272d0c'
This commit is contained in:
commit
035d3b1078
|
@ -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`
|
||||
|
|
|
@ -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) \
|
||||
|
|
|
@ -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) \
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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) \
|
||||
|
|
|
@ -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) {
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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})
|
|
@ -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")
|
|
@ -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);
|
||||
}
|
||||
}
|
||||
}
|
File diff suppressed because it is too large
Load Diff
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
*
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1,3 @@
|
|||
#!/bin/bash
|
||||
|
||||
ctags -e -R *
|
|
@ -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
|
|
@ -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);
|
||||
}
|
|
@ -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))))
|
|
@ -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))))
|
|
@ -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))
|
||||
|
|
@ -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) {
|
||||
|
|
|
@ -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
|
|
@ -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;
|
||||
}
|
|
@ -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
|
|
@ -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;
|
||||
}
|
|
@ -0,0 +1,4 @@
|
|||
#!/bin/sh
|
||||
|
||||
make clean
|
||||
infer run -- make all64
|
|
@ -0,0 +1,4 @@
|
|||
#!/bin/sh
|
||||
|
||||
make clean
|
||||
scan-build-10 -o ./static_analysis make -j4
|
|
@ -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))
|
|
@ -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))
|
Binary file not shown.
After Width: | Height: | Size: 323 KiB |
|
@ -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*/
|
||||
}
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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;
|
||||
}
|
|
@ -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) {
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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},
|
||||
|
|
|
@ -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); */
|
||||
/* } */
|
||||
|
|
|
@ -0,0 +1,5 @@
|
|||
|
||||
|
||||
(define arr [type-float 1 2 3 4 5])
|
||||
|
||||
(= (array-read arr 3) 4.0)
|
|
@ -0,0 +1,4 @@
|
|||
|
||||
(define arr [type-float 1.0 2.0 3.0 4.0 5.0])
|
||||
|
||||
(= (array-read arr 3) 4.0)
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(eq (car 1) nil)
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(eq (car '(1 . 2)) 1)
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(eq (car [1 2 3]) nil)
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(eq (cdr 1) nil)
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(eq (cdr '(1 . 2)) 2)
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(eq (cdr [1 2 3 4]) nil)
|
|
@ -0,0 +1,5 @@
|
|||
(define f (lambda (x y z w) (+ x y z w)))
|
||||
|
||||
(= ((f 1) 2 3 4) 10)
|
||||
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
(define f (lambda (x y z w) (+ x y z w)))
|
||||
|
||||
(= (((f 1) 2) 3 4) 10)
|
|
@ -0,0 +1,3 @@
|
|||
(define f (lambda (x y z w) (+ x y z w)))
|
||||
|
||||
(= ((((f 1) 2) 3) 4) 10)
|
|
@ -0,0 +1,5 @@
|
|||
(define f (lambda (x y z w) (+ x y z w)))
|
||||
|
||||
(define g (f 1 2))
|
||||
|
||||
(= (g 3 4) 10)
|
|
@ -0,0 +1,5 @@
|
|||
(define f (lambda (x y z w) (+ x y z w)))
|
||||
|
||||
(define g (f 1 2))
|
||||
|
||||
(= ((g 3) 4) 10)
|
|
@ -0,0 +1,4 @@
|
|||
(let ((apa 2))
|
||||
(defun f (x y z w) (+ apa x y z w)))
|
||||
|
||||
(= ((f 1) 2 3 4) 12)
|
|
@ -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))))
|
||||
|
|
Loading…
Reference in New Issue